From 270ac9c269890333478cf4bcae94a8c6aed4f1aa Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:01:39 +0200 Subject: [PATCH 01/26] irmin-lwt: opam files for the shim packages Adds opam metadata for [irmin-lwt] core and the eight backend / helper packages: [irmin-lwt-mem], [irmin-lwt-pack], [irmin-lwt-fs], [irmin-lwt-chunk], [irmin-lwt-containers], [irmin-lwt-git], [irmin-lwt-client], [irmin-lwt-tezos], plus the test harness [irmin-lwt-test]. --- irmin-lwt-chunk.opam | 34 ++++++++++++++++++++++++++++++++++ irmin-lwt-client.opam | 35 +++++++++++++++++++++++++++++++++++ irmin-lwt-containers.opam | 38 ++++++++++++++++++++++++++++++++++++++ irmin-lwt-fs.opam | 35 +++++++++++++++++++++++++++++++++++ irmin-lwt-git.opam | 35 +++++++++++++++++++++++++++++++++++ irmin-lwt-mem.opam | 33 +++++++++++++++++++++++++++++++++ irmin-lwt-pack.opam | 34 ++++++++++++++++++++++++++++++++++ irmin-lwt-test.opam | 37 +++++++++++++++++++++++++++++++++++++ irmin-lwt-tezos.opam | 35 +++++++++++++++++++++++++++++++++++ irmin-lwt.opam | 34 ++++++++++++++++++++++++++++++++++ 10 files changed, 350 insertions(+) create mode 100644 irmin-lwt-chunk.opam create mode 100644 irmin-lwt-client.opam create mode 100644 irmin-lwt-containers.opam create mode 100644 irmin-lwt-fs.opam create mode 100644 irmin-lwt-git.opam create mode 100644 irmin-lwt-mem.opam create mode 100644 irmin-lwt-pack.opam create mode 100644 irmin-lwt-test.opam create mode 100644 irmin-lwt-tezos.opam create mode 100644 irmin-lwt.opam 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)" ] From a196b3f489cfa5e169e6d3193d9faef7d06ff2d7 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:03:42 +0200 Subject: [PATCH 02/26] irmin-lwt: copy Lwt-typed Irmin 3 sources verbatim from main This commit imports 83 module-type and module-implementation files from [main:src/irmin/], unchanged. They form the Lwt-typed surface layer of the shim: - Module types and signatures: read_only, append_only, indexable, content_addressable, atomic_write, contents, branch, node, commit, metadata, schema, slice, remote, sync, dot, watch, storage, lock, lru, store, store_properties, tree, proof, object_graph, hash, path, info, conf, key, perms, type, diff, merge, metrics, version, backend, plus their *_intf.ml siblings. - Implementation files imported verbatim: branch.ml, commit.ml, contents.ml, dot.ml, hash.ml, info.ml, lock.ml, lru.ml, metadata.ml, metrics.ml, node.ml, object_graph.ml, path.ml, perms.ml, proof.ml, remote.ml, schema.ml, slice.ml, storage.ml, store.ml, store_properties.ml, sync.ml, tree.ml, type.ml, watch.ml, plus the export_for_backends and import shims. Each file is byte-identical to its main:src/irmin/ source at the time of import. Subsequent commits adapt them to the shim's needs (project-wide ocamlformat reformat, stripping of [Make] implementations, transparent re-exports of pure modules from Irmin 4, signature tweaks). --- src/irmin-lwt/core/append_only.ml | 17 + src/irmin-lwt/core/append_only.mli | 18 + src/irmin-lwt/core/append_only_intf.ml | 51 + src/irmin-lwt/core/atomic_write.ml | 61 + src/irmin-lwt/core/atomic_write.mli | 18 + src/irmin-lwt/core/atomic_write_intf.ml | 110 + src/irmin-lwt/core/backend.ml | 119 + src/irmin-lwt/core/branch.ml | 36 + src/irmin-lwt/core/branch.mli | 20 + src/irmin-lwt/core/branch_intf.ml | 62 + src/irmin-lwt/core/commit.ml | 699 ++++ src/irmin-lwt/core/commit.mli | 27 + src/irmin-lwt/core/commit_intf.ml | 332 ++ src/irmin-lwt/core/conf.ml | 178 ++ src/irmin-lwt/core/conf.mli | 167 + src/irmin-lwt/core/content_addressable.ml | 84 + src/irmin-lwt/core/content_addressable.mli | 18 + .../core/content_addressable_intf.ml | 69 + src/irmin-lwt/core/contents.ml | 251 ++ src/irmin-lwt/core/contents.mli | 20 + src/irmin-lwt/core/contents_intf.ml | 107 + src/irmin-lwt/core/diff.ml | 18 + src/irmin-lwt/core/dot.ml | 226 ++ src/irmin-lwt/core/dot.mli | 45 + src/irmin-lwt/core/dune | 22 + src/irmin-lwt/core/export_for_backends.ml | 21 + src/irmin-lwt/core/hash.ml | 118 + src/irmin-lwt/core/import.ml | 164 + src/irmin-lwt/core/indexable.ml | 83 + src/irmin-lwt/core/indexable.mli | 19 + src/irmin-lwt/core/indexable_intf.ml | 149 + src/irmin-lwt/core/info.ml | 41 + src/irmin-lwt/core/key.ml | 25 + src/irmin-lwt/core/lock.ml | 66 + src/irmin-lwt/core/lock.mli | 37 + src/irmin-lwt/core/lru.ml | 155 + src/irmin-lwt/core/lru.mli | 28 + src/irmin-lwt/core/merge.ml | 421 +++ src/irmin-lwt/core/merge.mli | 227 ++ src/irmin-lwt/core/metadata.ml | 24 + src/irmin-lwt/core/metadata.mli | 18 + src/irmin-lwt/core/metadata_intf.ml | 31 + src/irmin-lwt/core/metrics.ml | 46 + src/irmin-lwt/core/node.ml | 789 +++++ src/irmin-lwt/core/node.mli | 27 + src/irmin-lwt/core/node_intf.ml | 477 +++ src/irmin-lwt/core/object_graph.ml | 291 ++ src/irmin-lwt/core/object_graph.mli | 20 + src/irmin-lwt/core/object_graph_intf.ml | 139 + src/irmin-lwt/core/path.ml | 48 + src/irmin-lwt/core/perms.ml | 66 + src/irmin-lwt/core/proof.ml | 275 ++ src/irmin-lwt/core/proof.mli | 17 + src/irmin-lwt/core/proof_intf.ml | 279 ++ src/irmin-lwt/core/read_only.ml | 17 + src/irmin-lwt/core/read_only.mli | 18 + src/irmin-lwt/core/read_only_intf.ml | 57 + src/irmin-lwt/core/remote.ml | 33 + src/irmin-lwt/core/remote.mli | 20 + src/irmin-lwt/core/remote_intf.ml | 69 + src/irmin-lwt/core/schema.ml | 73 + src/irmin-lwt/core/slice.ml | 58 + src/irmin-lwt/core/slice.mli | 18 + src/irmin-lwt/core/slice_intf.ml | 56 + src/irmin-lwt/core/storage.ml | 146 + src/irmin-lwt/core/storage.mli | 23 + src/irmin-lwt/core/storage_intf.ml | 62 + src/irmin-lwt/core/store.ml | 1302 ++++++++ src/irmin-lwt/core/store.mli | 21 + src/irmin-lwt/core/store_intf.ml | 1251 ++++++++ src/irmin-lwt/core/store_properties.ml | 19 + src/irmin-lwt/core/store_properties.mli | 18 + src/irmin-lwt/core/store_properties_intf.ml | 72 + src/irmin-lwt/core/sync.ml | 221 ++ src/irmin-lwt/core/sync.mli | 20 + src/irmin-lwt/core/sync_intf.ml | 102 + src/irmin-lwt/core/tree.ml | 2833 +++++++++++++++++ src/irmin-lwt/core/tree.mli | 19 + src/irmin-lwt/core/tree_intf.ml | 494 +++ src/irmin-lwt/core/type.ml | 23 + src/irmin-lwt/core/watch.ml | 326 ++ src/irmin-lwt/core/watch.mli | 21 + src/irmin-lwt/core/watch_intf.ml | 96 + 83 files changed, 14364 insertions(+) create mode 100644 src/irmin-lwt/core/append_only.ml create mode 100644 src/irmin-lwt/core/append_only.mli create mode 100644 src/irmin-lwt/core/append_only_intf.ml create mode 100644 src/irmin-lwt/core/atomic_write.ml create mode 100644 src/irmin-lwt/core/atomic_write.mli create mode 100644 src/irmin-lwt/core/atomic_write_intf.ml create mode 100644 src/irmin-lwt/core/backend.ml create mode 100644 src/irmin-lwt/core/branch.ml create mode 100644 src/irmin-lwt/core/branch.mli create mode 100644 src/irmin-lwt/core/branch_intf.ml create mode 100644 src/irmin-lwt/core/commit.ml create mode 100644 src/irmin-lwt/core/commit.mli create mode 100644 src/irmin-lwt/core/commit_intf.ml create mode 100644 src/irmin-lwt/core/conf.ml create mode 100644 src/irmin-lwt/core/conf.mli create mode 100644 src/irmin-lwt/core/content_addressable.ml create mode 100644 src/irmin-lwt/core/content_addressable.mli create mode 100644 src/irmin-lwt/core/content_addressable_intf.ml create mode 100644 src/irmin-lwt/core/contents.ml create mode 100644 src/irmin-lwt/core/contents.mli create mode 100644 src/irmin-lwt/core/contents_intf.ml create mode 100644 src/irmin-lwt/core/diff.ml create mode 100644 src/irmin-lwt/core/dot.ml create mode 100644 src/irmin-lwt/core/dot.mli create mode 100644 src/irmin-lwt/core/dune create mode 100644 src/irmin-lwt/core/export_for_backends.ml create mode 100644 src/irmin-lwt/core/hash.ml create mode 100644 src/irmin-lwt/core/import.ml create mode 100644 src/irmin-lwt/core/indexable.ml create mode 100644 src/irmin-lwt/core/indexable.mli create mode 100644 src/irmin-lwt/core/indexable_intf.ml create mode 100644 src/irmin-lwt/core/info.ml create mode 100644 src/irmin-lwt/core/key.ml create mode 100644 src/irmin-lwt/core/lock.ml create mode 100644 src/irmin-lwt/core/lock.mli create mode 100644 src/irmin-lwt/core/lru.ml create mode 100644 src/irmin-lwt/core/lru.mli create mode 100644 src/irmin-lwt/core/merge.ml create mode 100644 src/irmin-lwt/core/merge.mli create mode 100644 src/irmin-lwt/core/metadata.ml create mode 100644 src/irmin-lwt/core/metadata.mli create mode 100644 src/irmin-lwt/core/metadata_intf.ml create mode 100644 src/irmin-lwt/core/metrics.ml create mode 100644 src/irmin-lwt/core/node.ml create mode 100644 src/irmin-lwt/core/node.mli create mode 100644 src/irmin-lwt/core/node_intf.ml create mode 100644 src/irmin-lwt/core/object_graph.ml create mode 100644 src/irmin-lwt/core/object_graph.mli create mode 100644 src/irmin-lwt/core/object_graph_intf.ml create mode 100644 src/irmin-lwt/core/path.ml create mode 100644 src/irmin-lwt/core/perms.ml create mode 100644 src/irmin-lwt/core/proof.ml create mode 100644 src/irmin-lwt/core/proof.mli create mode 100644 src/irmin-lwt/core/proof_intf.ml create mode 100644 src/irmin-lwt/core/read_only.ml create mode 100644 src/irmin-lwt/core/read_only.mli create mode 100644 src/irmin-lwt/core/read_only_intf.ml create mode 100644 src/irmin-lwt/core/remote.ml create mode 100644 src/irmin-lwt/core/remote.mli create mode 100644 src/irmin-lwt/core/remote_intf.ml create mode 100644 src/irmin-lwt/core/schema.ml create mode 100644 src/irmin-lwt/core/slice.ml create mode 100644 src/irmin-lwt/core/slice.mli create mode 100644 src/irmin-lwt/core/slice_intf.ml create mode 100644 src/irmin-lwt/core/storage.ml create mode 100644 src/irmin-lwt/core/storage.mli create mode 100644 src/irmin-lwt/core/storage_intf.ml create mode 100644 src/irmin-lwt/core/store.ml create mode 100644 src/irmin-lwt/core/store.mli create mode 100644 src/irmin-lwt/core/store_intf.ml create mode 100644 src/irmin-lwt/core/store_properties.ml create mode 100644 src/irmin-lwt/core/store_properties.mli create mode 100644 src/irmin-lwt/core/store_properties_intf.ml create mode 100644 src/irmin-lwt/core/sync.ml create mode 100644 src/irmin-lwt/core/sync.mli create mode 100644 src/irmin-lwt/core/sync_intf.ml create mode 100644 src/irmin-lwt/core/tree.ml create mode 100644 src/irmin-lwt/core/tree.mli create mode 100644 src/irmin-lwt/core/tree_intf.ml create mode 100644 src/irmin-lwt/core/type.ml create mode 100644 src/irmin-lwt/core/watch.ml create mode 100644 src/irmin-lwt/core/watch.mli create mode 100644 src/irmin-lwt/core/watch_intf.ml diff --git a/src/irmin-lwt/core/append_only.ml b/src/irmin-lwt/core/append_only.ml new file mode 100644 index 0000000000..2075b21c1c --- /dev/null +++ b/src/irmin-lwt/core/append_only.ml @@ -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 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..a34a4c28f8 --- /dev/null +++ b/src/irmin-lwt/core/branch_intf.ml @@ -0,0 +1,62 @@ +(* + * 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..da05c48173 --- /dev/null +++ b/src/irmin-lwt/core/commit.ml @@ -0,0 +1,699 @@ +(* + * 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..7b0eddc57b --- /dev/null +++ b/src/irmin-lwt/core/commit_intf.ml @@ -0,0 +1,332 @@ +(* + * 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..0788380ce0 --- /dev/null +++ b/src/irmin-lwt/core/conf.ml @@ -0,0 +1,178 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2017 Daniel C. Bünzli + * + * 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 Univ = struct + type t = exn + + let create (type s) () = + let module M = struct + exception E of s option + end in + ((fun x -> M.E (Some x)), function M.E x -> x | _ -> None) +end + +type 'a key = { + name : string; + doc : string option; + docv : string option; + docs : string option; + ty : 'a Type.t; + default : 'a; + to_univ : 'a -> Univ.t; + of_univ : Univ.t -> 'a option; +} + +type k = K : 'a key -> k + +module M = Map.Make (struct + type t = k + + let compare (K a) (K b) = String.compare a.name b.name +end) + +module Spec = struct + module M = Map.Make (String) + + type t = { name : string; mutable keys : k M.t } + + let all = Hashtbl.create 8 + + let v name = + let keys = M.empty in + if Hashtbl.mem all name then + Fmt.failwith "Config spec already exists: %s" name; + let x = { name; keys } in + Hashtbl.replace all name x; + x + + let name { name; _ } = name + let update spec name k = spec.keys <- M.add name k spec.keys + let list () = Hashtbl.to_seq_values all + let find name = Hashtbl.find_opt all name + let find_key spec name = M.find_opt name spec.keys + let keys spec = M.to_seq spec.keys |> Seq.map snd + let clone { name; keys } = { name; keys } + + let join dest src = + let dest = clone dest in + let name = ref dest.name in + let keys = + List.fold_left + (fun acc spec -> + if dest.name = spec.name then acc + else + let () = name := !name ^ "-" ^ spec.name in + M.add_seq (M.to_seq spec.keys) acc) + dest.keys src + in + { name = !name; keys } +end + +type t = Spec.t * Univ.t M.t + +let spec = fst + +let key ?docs ?docv ?doc ~spec name ty default = + let () = + String.iter + (function + | '-' | '_' | 'a' .. 'z' | '0' .. '9' -> () + | _ -> raise @@ Invalid_argument name) + name + in + match Spec.find_key spec name with + | Some _ -> Fmt.invalid_arg "duplicate key: %s" name + | _ -> + let to_univ, of_univ = Univ.create () in + let k = { name; ty; default; to_univ; of_univ; doc; docv; docs } in + Spec.update spec name (K k); + k + +let name t = t.name +let doc t = t.doc +let docv t = t.docv +let docs t = t.docs +let ty t = t.ty +let default t = t.default +let empty spec = (spec, M.empty) +let singleton spec k v = (spec, M.singleton (K k) (k.to_univ v)) +let is_empty (_, t) = M.is_empty t +let mem (_, d) k = M.mem (K k) d + +let validate_key spec k = + match Spec.find_key spec k.name with + | None -> Fmt.invalid_arg "invalid config key: %s" k.name + | Some _ -> () + +let add (spec, d) k v = + validate_key spec k; + (spec, M.add (K k) (k.to_univ v) d) + +let verify (spec, d) = + M.iter (fun (K k) _ -> validate_key spec k) d; + (spec, d) + +let union (rs, r) (ss, s) = + let spec = Spec.join rs [ ss ] in + (spec, M.fold M.add r s) + +let rem (s, d) k = (s, M.remove (K k) d) +let find (_, d) k = try k.of_univ (M.find (K k) d) with Not_found -> None +let uri = Type.(map string) Uri.of_string Uri.to_string + +let get (_, d) k = + try + match k.of_univ (M.find (K k) d) with + | Some v -> v + | None -> raise Not_found + with Not_found -> k.default + +let keys (_, conf) = M.to_seq conf |> Seq.map (fun (k, _) -> k) +let with_spec (_, conf) spec = (spec, conf) + +let to_strings (_, conf) = + conf + |> M.to_seq + |> Seq.map (fun (K k, v) -> + ( k.name, + match k.of_univ v with + | Some v -> Type.to_string k.ty v + | None -> assert false )) + +let pp ppf t = + t |> to_strings |> List.of_seq |> Fmt.Dump.(list (pair string string)) ppf + +let equal t1 t2 = + t1 == t2 + || Seq.for_all2 + (fun (k1, v1) (k2, v2) -> String.equal k1 k2 && String.equal v1 v2) + (to_strings t1) (to_strings t2) + +(* ~root *) +let root spec = + key ~spec ~docv:"ROOT" ~doc:"The location of the Irmin store on disk." + ~docs:"COMMON OPTIONS" "root" + Type.(string) + "." + +let find_root (spec, d) : string option = + match Spec.find_key spec "root" with + | None -> None + | Some (K k) -> ( + let v = find (spec, d) k in + match v with None -> None | Some v -> Some (Type.to_string k.ty v)) diff --git a/src/irmin-lwt/core/conf.mli b/src/irmin-lwt/core/conf.mli new file mode 100644 index 0000000000..e850a49d2a --- /dev/null +++ b/src/irmin-lwt/core/conf.mli @@ -0,0 +1,167 @@ +(* + * 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 Configuration converters} + + A configuration converter transforms a string value to an OCaml value and + vice-versa. *) + +(** {1:keys Keys} *) + +type 'a key +(** The type for configuration keys whose lookup value is ['a]. *) + +type k = K : 'a key -> k + +module Spec : sig + type t + (** A configuration spec is used to group keys by backend *) + + val v : string -> t + (** [v name] is a new configuration specification named [name] *) + + val name : t -> string + (** [name spec] is the name associated with a config spec *) + + val list : unit -> t Seq.t + (** [list ()] is a sequence containing all available config specs *) + + val find : string -> t option + (** [find name] is the config spec associated with [name] if available *) + + val find_key : t -> string -> k option + (** [find_key spec k] is the key associated with the name [k] in [spec] *) + + val keys : t -> k Seq.t + (** [keys spec] is a sequence of keys available in [spec] *) + + val join : t -> t list -> t + (** [join a b] is a new [Spec.t] combining [a] and all specs present in [b] + + The name of the resulting spec will be the name of [a] and the names of + the specs in [b] joined by hyphens. *) +end + +val key : + ?docs:string -> + ?docv:string -> + ?doc:string -> + spec:Spec.t -> + string -> + 'a Type.t -> + 'a -> + 'a key +(** [key ~docs ~docv ~doc ~spec name conv default] is a configuration key named + [name] that maps to value [default] by default. It will be associated with + the config grouping [spec]. [conv] is used to convert key values provided by + end users. + + [docs] is the title of a documentation section under which the key is + documented. [doc] is a short documentation string for the key, this should + be a single sentence or paragraph starting with a capital letter and ending + with a dot. [docv] is a meta-variable for representing the values of the key + (e.g. ["BOOL"] for a boolean). + + @raise Invalid_argument + if the key name is not made of a sequence of ASCII lowercase letter, + digit, dash or underscore. + @raise Invalid_argument + if [allow_duplicate] is [false] (the default) and [name] has already been + used to create a key *) + +val name : 'a key -> string +(** The key name. *) + +val ty : 'a key -> 'a Type.t +(** [tc k] is [k]'s converter. *) + +val default : 'a key -> 'a +(** [default k] is [k]'s default value. *) + +val doc : 'a key -> string option +(** [doc k] is [k]'s documentation string (if any). *) + +val docv : 'a key -> string option +(** [docv k] is [k]'s value documentation meta-variable (if any). *) + +val docs : 'a key -> string option +(** [docs k] is [k]'s documentation section (if any). *) + +val root : Spec.t -> string key +(** Default [--root=ROOT] argument. *) + +(** {1:conf Configurations} *) + +type t +(** The type for configurations. *) + +val pp : t Fmt.t +(** [pp] is the pretty printer for configuration values. *) + +val equal : t -> t -> bool +(** [equal] is the equality for configuration values. Two values are equal if + they have the same [pp] representation. *) + +val spec : t -> Spec.t +(** [spec c] is the specification associated with [c] *) + +val empty : Spec.t -> t +(** [empty spec] is an empty configuration. *) + +val singleton : Spec.t -> 'a key -> 'a -> t +(** [singleton spec k v] is the configuration where [k] maps to [v]. *) + +val is_empty : t -> bool +(** [is_empty c] is [true] iff [c] is empty. *) + +val mem : t -> 'a key -> bool +(** [mem c k] is [true] iff [k] has a mapping in [c]. *) + +val add : t -> 'a key -> 'a -> t +(** [add c k v] is [c] with [k] mapping to [v]. *) + +val rem : t -> 'a key -> t +(** [rem c k] is [c] with [k] unbound. *) + +val union : t -> t -> t +(** [union r s] is the union of the configurations [r] and [s]. *) + +val find : t -> 'a key -> 'a option +(** [find c k] is [k]'s mapping in [c], if any. *) + +val get : t -> 'a key -> 'a +(** [get c k] is [k]'s mapping in [c]. + + {b Raises.} [Not_found] if [k] is not bound in [d]. *) + +val keys : t -> k Seq.t +(** [keys c] is a sequence of all keys present in [c] *) + +val with_spec : t -> Spec.t -> t +(** [with_spec t s] is the config [t] with spec [s] *) + +val verify : t -> t +(** [verify t] is an identity function that ensures all keys match the spec + + {b Raises.} [Invalid_argument] if [t] contains invalid keys *) + +(** {1:builtin_converters Built-in value converters} *) + +val uri : Uri.t Type.t +(** [uri] converts values with {!Uri.of_string}. *) + +val find_root : t -> string option +(** [find_root c] is [root]'s mapping in [c], if any. *) 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..64c0811f84 --- /dev/null +++ b/src/irmin-lwt/core/contents_intf.ml @@ -0,0 +1,107 @@ +(* + * 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..8e0e4d2773 --- /dev/null +++ b/src/irmin-lwt/core/diff.ml @@ -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. + *) + +type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] +[@@deriving irmin] 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..938a2ff5ec --- /dev/null +++ b/src/irmin-lwt/core/dune @@ -0,0 +1,22 @@ +(library + (name irmin) + (public_name irmin) + (libraries + irmin.data + astring + bheap + digestif + fmt + jsonm + logs + logs.fmt + lwt + mtime + ocamlgraph + uri + uutf + (re_export repr)) + (preprocess + (pps ppx_irmin.internal -- --lib "Type")) + (instrumentation + (backend bisect_ppx))) 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..507a4913b6 --- /dev/null +++ b/src/irmin-lwt/core/export_for_backends.ml @@ -0,0 +1,21 @@ +(* + * 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 Store_properties = Store_properties +module Logging = Logging +module Reversed_list = Reversed_list +include Import diff --git a/src/irmin-lwt/core/hash.ml b/src/irmin-lwt/core/hash.ml new file mode 100644 index 0000000000..c99a0a620d --- /dev/null +++ b/src/irmin-lwt/core/hash.ml @@ -0,0 +1,118 @@ +(* + * 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 Hash_intf + +module Make (H : Digestif.S) = struct + type t = H.t + + external get_64 : string -> int -> int64 = "%caml_string_get64u" + external swap64 : int64 -> int64 = "%bswap_int64" + + let get_64_little_endian str idx = + if Sys.big_endian then swap64 (get_64 str idx) else get_64 str idx + + let short_hash c = Int64.to_int (get_64_little_endian (H.to_raw_string c) 0) + + let short_hash_substring bigstring ~off = + Int64.to_int (Bigstringaf.get_int64_le bigstring off) + + let hash_size = H.digest_size + + let of_hex s = + match H.consistent_of_hex s with + | x -> Ok x + | exception Invalid_argument e -> Error (`Msg e) + + let pp_hex ppf x = Fmt.string ppf (H.to_hex x) + + let t = + Type.map ~pp:pp_hex ~of_string:of_hex + Type.(string_of (`Fixed hash_size)) + H.of_raw_string H.to_raw_string + + let hash s = H.digesti_string s + let to_raw_string s = H.to_raw_string s + let unsafe_of_raw_string s = H.of_raw_string s +end + +module Make_BLAKE2B (D : sig + val digest_size : int +end) = + Make (Digestif.Make_BLAKE2B (D)) + +module Make_BLAKE2S (D : sig + val digest_size : int +end) = + Make (Digestif.Make_BLAKE2S (D)) + +module SHA1 = Make (Digestif.SHA1) +module RMD160 = Make (Digestif.RMD160) +module SHA224 = Make (Digestif.SHA224) +module SHA256 = Make (Digestif.SHA256) +module SHA384 = Make (Digestif.SHA384) +module SHA512 = Make (Digestif.SHA512) +module BLAKE2B = Make (Digestif.BLAKE2B) +module BLAKE2S = Make (Digestif.BLAKE2S) + +module Typed (K : S) (V : Type.S) = struct + include K + + type value = V.t [@@deriving irmin ~pre_hash] + + let hash v = K.hash (pre_hash_value v) +end + +module V1 (K : S) : S with type t = K.t = struct + type t = K.t [@@deriving irmin ~encode_bin ~decode_bin] + + let hash = K.hash + let short_hash = K.short_hash + let short_hash_substring = K.short_hash_substring + let hash_size = K.hash_size + let int64_to_bin_string = Type.(unstage (to_bin_string int64)) + let hash_size_str = int64_to_bin_string (Int64.of_int K.hash_size) + let to_raw_string = K.to_raw_string + let unsafe_of_raw_string = K.unsafe_of_raw_string + + let encode_bin e f = + f hash_size_str; + encode_bin e f + + let decode_bin buf pos_ref = + pos_ref := !pos_ref + 8; + decode_bin buf pos_ref + + let size_of = Type.Size.custom_static (8 + hash_size) + let t = Type.like K.t ~bin:(encode_bin, decode_bin, size_of) +end + +module Set = struct + module Make (Hash : S) = struct + include Irmin_data.Fixed_size_string_set + + let create ?(initial_slots = 0) () = + let elt_length = Hash.hash_size + and hash s = Hash.(short_hash (unsafe_of_raw_string s)) + and hash_substring t ~off ~len:_ = Hash.short_hash_substring t ~off in + create ~elt_length ~initial_slots ~hash ~hash_substring () + + let add t h = add t (Hash.to_raw_string h) + let mem t h = mem t (Hash.to_raw_string h) + end + + module type S = Set +end 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..9cf6d34042 --- /dev/null +++ b/src/irmin-lwt/core/info.ml @@ -0,0 +1,41 @@ +(* + * 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 Info_intf + +module Default = struct + type author = string [@@deriving irmin] + type message = string [@@deriving irmin] + + type t = { date : int64; author : author; message : message } + [@@deriving irmin ~equal] + + type f = unit -> t + + let empty = { date = 0L; author = ""; message = "" } + let is_empty = equal empty + + let v ?(author = "") ?(message = "") date = + let r = { date; message; author } in + if is_empty r then empty else r + + let date t = t.date + let author t = t.author + let message t = t.message + let none () = empty +end + +type default = Default.t diff --git a/src/irmin-lwt/core/key.ml b/src/irmin-lwt/core/key.ml new file mode 100644 index 0000000000..c7b86c388e --- /dev/null +++ b/src/irmin-lwt/core/key.ml @@ -0,0 +1,25 @@ +(* + * 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 Key_intf + +module Of_hash (Hash : Type.S) = struct + type t = Hash.t [@@deriving irmin] + type hash = Hash.t + + let to_hash x = x [@@inline] + let of_hash x = x [@@inline] +end 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/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..2ec7b19f34 --- /dev/null +++ b/src/irmin-lwt/core/merge.mli @@ -0,0 +1,227 @@ +(* + * 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..eb3422c4c1 --- /dev/null +++ b/src/irmin-lwt/core/metrics.ml @@ -0,0 +1,46 @@ +(* +* Copyright (c) 2022 - Étienne Marais +* +* Permission to use, copy, modify, and distribute this software for any +* purpose with or without fee is hereby granted, provided that the above +* copyright notice and this permission notice appear in all copies. +* +* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +*) + +let uid = + let id = ref (-1) in + fun () -> + incr id; + !id + +type origin = .. + +type 'a t = { + uid : int; + name : string; + origin : origin option; + repr : 'a Repr.ty; + mutable state : 'a; +} + +let state m = m.state +let set_state m v = m.state <- v + +type 'a update_mode = Mutate of ('a -> unit) | Replace of ('a -> 'a) + +let v : + type a. ?origin:origin -> name:string -> initial_state:a -> a Repr.ty -> a t + = + fun ?origin ~name ~initial_state repr -> + { uid = uid (); origin; name; repr; state = initial_state } + +let update : type a. a t -> a update_mode -> unit = + fun m kind -> + match kind with Mutate f -> f m.state | Replace f -> m.state <- f m.state diff --git a/src/irmin-lwt/core/node.ml b/src/irmin-lwt/core/node.ml new file mode 100644 index 0000000000..a13a953688 --- /dev/null +++ b/src/irmin-lwt/core/node.ml @@ -0,0 +1,789 @@ +(* + * 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..2fae339997 --- /dev/null +++ b/src/irmin-lwt/core/node_intf.ml @@ -0,0 +1,477 @@ +(* + * 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..95b73760b6 --- /dev/null +++ b/src/irmin-lwt/core/path.ml @@ -0,0 +1,48 @@ +(* + * 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 Astring +include Path_intf + +module String_list = struct + type step = string [@@deriving irmin] + type t = step list + + let empty = [] + let is_empty l = l = [] + let cons s t = s :: t + let rcons t s = t @ [ s ] + let decons = function [] -> None | h :: t -> Some (h, t) + + let rdecons l = + match List.rev l with [] -> None | h :: t -> Some (List.rev t, h) + + let map l f = List.map f l + let v x = x + + let pp ppf t = + let len = List.fold_left (fun acc s -> 1 + acc + String.length s) 1 t in + let buf = Buffer.create len in + List.iter + (fun s -> + Buffer.add_char buf '/'; + Buffer.add_string buf s) + t; + Fmt.string ppf (Buffer.contents buf) + + let of_string s = Ok (List.filter (( <> ) "") (String.cuts s ~sep:"/")) + let t = Type.like ~pp ~of_string Type.(list step_t) +end diff --git a/src/irmin-lwt/core/perms.ml b/src/irmin-lwt/core/perms.ml new file mode 100644 index 0000000000..1d66477f05 --- /dev/null +++ b/src/irmin-lwt/core/perms.ml @@ -0,0 +1,66 @@ +(* + * 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. + *) + +(** Types representing {i permissions} ['perms] for performing operations on a + certain type ['perms t]. + + They are intended to be used as phantom parameters of the types that they + control access to. As an example, consider the following type of references + with permissions: + + {[ + module Ref : sig + type (+'a, -'perms) t + + val create : 'a -> ('a, read_write) t + val get : ('a, [> read ]) t -> 'a + val set : ('a, [> write ]) t -> 'a -> unit + end + ]} + + This type allows references to be created with arbitrary read-write access. + One can then create weaker views onto the reference – with access to fewer + operations – by upcasting: + + {[ + let read_only t = (t :> (_, read) Ref.t) + let write_only t = (t :> (_, write) Ref.t) + ]} + + Note that the ['perms] phantom type parameter should be contravariant: it's + safe to discard permissions, but not to gain new ones. *) + +module Read = struct + type t = [ `Read ] +end + +module Write = struct + type t = [ `Write ] +end + +module Read_write = struct + type t = [ Read.t | Write.t ] +end + +type read = Read.t +(** The type parameter of a handle with [read] permissions. *) + +type write = Write.t +(** The type parameter of a handle with [write] permissions. *) + +type read_write = Read_write.t +(** The type parameter of a handle with both {!read} and {!write} permissions. *) diff --git a/src/irmin-lwt/core/proof.ml b/src/irmin-lwt/core/proof.ml new file mode 100644 index 0000000000..f1cdd1b1bf --- /dev/null +++ b/src/irmin-lwt/core/proof.ml @@ -0,0 +1,275 @@ +(* + * 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..f32892a1d8 --- /dev/null +++ b/src/irmin-lwt/core/proof_intf.ml @@ -0,0 +1,279 @@ +(* + * 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..95cc3d33a0 --- /dev/null +++ b/src/irmin-lwt/core/read_only.ml @@ -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 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..4237c9a058 --- /dev/null +++ b/src/irmin-lwt/core/remote_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. + *) + +type t = .. + +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..34486228e8 --- /dev/null +++ b/src/irmin-lwt/core/storage_intf.ml @@ -0,0 +1,62 @@ +(* + * 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..b73edf07bd --- /dev/null +++ b/src/irmin-lwt/core/store.ml @@ -0,0 +1,1302 @@ +(* + * 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 Store_intf +open Merge.Infix + +let src = Logs.Src.create "irmin" ~doc:"Irmin branch-consistent store" + +module Log = (val Logs.src_log src : Logs.LOG) + +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 Make (B : Backend.S) = struct + module Schema = B.Schema + module Contents_key = B.Contents.Key + module Node_key = B.Node.Key + module Commit_key = B.Commit.Key + module Metadata = B.Node.Metadata + module Typed = Hash.Typed (B.Hash) + module Hash = B.Hash + module Branch_store = B.Branch + module Path = B.Node.Path + module Commits = Commit.History (B.Commit) + module Backend = B + module T = Tree.Make (B) + + module Info = struct + include B.Commit.Info + + let pp = Type.pp t + end + + module Contents = struct + include B.Contents.Val + module H = Typed (B.Contents.Val) + + let of_key r k = B.Contents.find (B.Repo.contents_t r) k + + let of_hash r h = + let store = B.Repo.contents_t r in + B.Contents.index store h >>= function + | None -> Lwt.return_none + | Some k -> B.Contents.find store k + + let hash c = H.hash c + end + + module Tree = struct + include T + + let find_key r t = + match key t with + | Some k -> Lwt.return (Some k) + | None -> ( + match hash t with + | `Node h -> ( + B.Node.index (B.Repo.node_t r) h >|= function + | None -> None + | Some k -> Some (`Node k)) + | `Contents (h, m) -> ( + B.Contents.index (B.Repo.contents_t r) h >|= function + | None -> None + | Some k -> Some (`Contents (k, m)))) + + let of_key r k = import r k + + let of_hash r = function + | `Node h -> ( + B.Node.index (B.Repo.node_t r) h >>= function + | None -> Lwt.return_none + | Some k -> of_key r (`Node k)) + | `Contents (h, m) -> ( + B.Contents.index (B.Repo.contents_t r) h >>= function + | None -> Lwt.return_none + | Some k -> of_key r (`Contents (k, m))) + + let shallow r h = import_no_check r h + let kinded_hash = hash + + let hash : ?cache:bool -> t -> hash = + fun ?cache tr -> + match hash ?cache tr with `Node h -> h | `Contents (h, _) -> h + + let pp = Type.pp t + end + + type branch = Branch_store.Key.t [@@deriving irmin ~equal ~pp] + type contents_key = B.Contents.Key.t [@@deriving irmin ~pp ~equal] + type node_key = B.Node.Key.t [@@deriving irmin ~pp ~equal] + type commit_key = B.Commit.Key.t [@@deriving irmin ~pp ~equal] + type repo = B.Repo.t + type commit = { r : repo; key : commit_key; v : B.Commit.value } + type hash = Hash.t [@@deriving irmin ~equal ~pp ~compare] + type node = Tree.node [@@deriving irmin] + type contents = Contents.t [@@deriving irmin ~equal] + type metadata = Metadata.t [@@deriving irmin] + type tree = Tree.t [@@deriving irmin ~pp] + type path = Path.t [@@deriving irmin ~pp] + type step = Path.step [@@deriving irmin] + type info = Info.t [@@deriving irmin] + type Remote.t += E of B.Remote.endpoint + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] [@@deriving irmin] + type ff_error = [ `Rejected | `No_change | lca_error ] + + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] + + (* The deriver does not work here because of it cannot derive the + [Merge.conflict] inheritance. *) + let write_error_t = + let open Type in + variant "write-error" (fun c m e -> function + | `Conflict x -> c x | `Too_many_retries x -> m x | `Test_was x -> e x) + |~ case1 "conflict" string (fun x -> `Conflict x) + |~ case1 "too-many-retries" int (fun x -> `Too_many_retries x) + |~ case1 "test-got" (option tree_t) (fun x -> `Test_was x) + |> sealv + + (* The deriver does not work here because of it cannot derive the + [lca_error] inheritance. *) + let ff_error_t = + Type.enum "ff-error" + [ + ("max-depth-reached", `Max_depth_reached); + ("too-many-lcas", `Too_many_lcas); + ("no-change", `No_change); + ("rejected", `Rejected); + ] + + let pp_int = Type.pp Type.int + let save_contents b c = B.Contents.add b c + + let save_tree ?(clear = true) r x y (tr : Tree.t) = + match Tree.destruct tr with + | `Contents (c, _) -> + let* c = Tree.Contents.force_exn c in + let+ k = save_contents x c in + `Contents k + | `Node n -> + let+ k = Tree.export ~clear r x y n in + `Node k + + module Contents_keys = Set.Make (struct + type t = Contents_key.t [@@deriving irmin ~compare] + end) + + module Commit = struct + type t = commit + + let t r = + let open Type in + record "commit" (fun key v -> { r; key; v }) + |+ field "key" B.Commit.Key.t (fun t -> t.key) + |+ field "value" B.Commit.Val.t (fun t -> t.v) + |> sealr + + let v ?(clear = true) r ~info ~parents tree = + B.Repo.batch r @@ fun contents_t node_t commit_t -> + let* node = + match Tree.destruct tree with + | `Node t -> Tree.export ~clear r contents_t node_t t + | `Contents _ -> Lwt.fail_invalid_arg "cannot add contents at the root" + in + let v = B.Commit.Val.v ~info ~node ~parents in + let+ key = B.Commit.add commit_t v in + { r; key; v } + + let node t = B.Commit.Val.node t.v + let tree t = Tree.import_no_check t.r (`Node (node t)) + let equal x y = equal_commit_key x.key y.key + let key t = t.key + let hash t = B.Commit.Key.to_hash t.key + let info t = B.Commit.Val.info t.v + let parents t = B.Commit.Val.parents t.v + let pp_hash ppf t = Type.pp Hash.t ppf (hash t) + let pp_key ppf t = Type.pp B.Commit.Key.t ppf t.key + let pp ppf commit = Type.pp (t commit.r) ppf commit + + let of_key r key = + B.Commit.find (B.Repo.commit_t r) key >|= function + | None -> None + | Some v -> Some { r; key; v } + + let of_hash r hash = + B.Commit.index (B.Repo.commit_t r) hash >>= function + | None -> Lwt.return_none + | Some key -> of_key r key + + module H = Typed (B.Commit.Val) + + let to_backend_commit t = t.v + let of_backend_commit r key v = { r; key; v } + + let equal_opt x y = + match (x, y) with + | None, None -> true + | Some x, Some y -> equal x y + | _ -> false + end + + let to_backend_portable_node = Tree.to_backend_portable_node + let to_backend_node = Tree.to_backend_node + let of_backend_node = Tree.of_backend_node + let to_backend_commit = Commit.to_backend_commit + let of_backend_commit = Commit.of_backend_commit + + type head_ref = [ `Branch of branch | `Head of commit option ref ] + + module OCamlGraph = Graph + module Graph = Node.Graph (B.Node) + + module KGraph = + Object_graph.Make (B.Contents.Key) (B.Node.Key) (B.Commit.Key) + (Branch_store.Key) + + type slice = B.Slice.t [@@deriving irmin] + type watch = unit -> unit Lwt.t + + let unwatch w = w () + + module Repo = struct + type t = repo + + let v = B.Repo.v + let config = B.Repo.config + let close = B.Repo.close + let branch_t t = B.Repo.branch_t t + let commit_t t = B.Repo.commit_t t + let node_t t = B.Repo.node_t t + let contents_t t = B.Repo.contents_t t + let branches t = B.Branch.list (branch_t t) + + let heads repo = + let t = branch_t repo in + let* bs = Branch_store.list t in + Lwt_list.fold_left_s + (fun acc r -> + Branch_store.find t r >>= function + | None -> Lwt.return acc + | Some k -> ( + Commit.of_key repo k >|= function + | None -> acc + | Some h -> h :: acc)) + [] bs + + let export ?(full = true) ?depth ?(min = []) ?(max = `Head) t = + [%log.debug + "export depth=%s full=%b min=%d max=%s" + (match depth with None -> "" | Some d -> string_of_int d) + full (List.length min) + (match max with + | `Head -> "heads" + | `Max m -> string_of_int (List.length m))]; + let* max = match max with `Head -> heads t | `Max m -> Lwt.return m in + let* slice = B.Slice.empty () in + let max = List.map (fun x -> `Commit x.key) max in + let min = List.map (fun x -> `Commit x.key) min in + let pred = function + | `Commit k -> + let+ parents = Commits.parents (commit_t t) k in + List.map (fun x -> `Commit x) parents + | _ -> Lwt.return_nil + in + let* g = KGraph.closure ?depth ~pred ~min ~max () in + let keys = + List.fold_left + (fun acc -> function `Commit c -> c :: acc | _ -> acc) + [] (KGraph.vertex g) + in + let root_nodes = ref [] in + let* () = + Lwt_list.iter_p + (fun k -> + B.Commit.find (commit_t t) k >>= function + | None -> Lwt.return_unit + | Some c -> + root_nodes := B.Commit.Val.node c :: !root_nodes; + B.Slice.add slice (`Commit (Commit_key.to_hash k, c))) + keys + in + if not full then Lwt.return slice + else + (* XXX: we can compute a [min] if needed *) + let* nodes = Graph.closure (node_t t) ~min:[] ~max:!root_nodes in + let contents = ref Contents_keys.empty in + let* () = + Lwt_list.iter_p + (fun k -> + B.Node.find (node_t t) k >>= function + | None -> Lwt.return_unit + | Some v -> + List.iter + (function + | _, `Contents (c, _) -> + contents := Contents_keys.add c !contents + | _ -> ()) + (B.Node.Val.list v); + B.Slice.add slice (`Node (Node_key.to_hash k, v))) + nodes + in + let+ () = + Lwt_list.iter_p + (fun k -> + B.Contents.find (contents_t t) k >>= function + | None -> Lwt.return_unit + | Some m -> + B.Slice.add slice (`Contents (Contents_key.to_hash k, m))) + (Contents_keys.elements !contents) + in + slice + + exception Import_error of string + + let import_error fmt = Fmt.kstr (fun x -> Lwt.fail (Import_error x)) fmt + + let import t s = + let aux name key_to_hash add (h, v) = + let* k' = add v in + let h' = key_to_hash k' in + if not (equal_hash h h') then + import_error "%s import error: expected %a, got %a" name pp_hash h + pp_hash h' + else Lwt.return_unit + in + let contents = ref [] in + let nodes = ref [] in + let commits = ref [] in + let* () = + B.Slice.iter s (function + | `Contents c -> + contents := c :: !contents; + Lwt.return_unit + | `Node n -> + nodes := n :: !nodes; + Lwt.return_unit + | `Commit c -> + commits := c :: !commits; + Lwt.return_unit) + in + B.Repo.batch t @@ fun contents_t node_t commit_t -> + Lwt.catch + (fun () -> + let* () = + Lwt_list.iter_p + (aux "Contents" B.Contents.Key.to_hash + (B.Contents.add contents_t)) + !contents + in + Lwt_list.iter_p + (aux "Node" B.Node.Key.to_hash (B.Node.add node_t)) + !nodes + >>= fun () -> + let+ () = + Lwt_list.iter_p + (aux "Commit" B.Commit.Key.to_hash (B.Commit.add commit_t)) + !commits + in + Ok ()) + (function + | Import_error e -> Lwt.return (Error (`Msg e)) + | e -> Fmt.kstr Lwt.fail_invalid_arg "impot error: %a" Fmt.exn e) + + type elt = + [ `Commit of commit_key + | `Node of node_key + | `Contents of contents_key + | `Branch of B.Branch.Key.t ] + [@@deriving irmin] + + let ignore_lwt _ = Lwt.return_unit + let return_false _ = Lwt.return false + let default_pred_contents _ _ = Lwt.return [] + + let default_pred_node t k = + B.Node.find (node_t t) k >|= function + | None -> [] + | Some v -> + List.rev_map + (function + | _, `Node n -> `Node n | _, `Contents (c, _) -> `Contents c) + (B.Node.Val.list v) + + let default_pred_commit t c = + B.Commit.find (commit_t t) c >|= function + | None -> + [%log.debug "%a: not found" pp_commit_key c]; + [] + | Some c -> + let node = B.Commit.Val.node c in + let parents = B.Commit.Val.parents c in + [ `Node node ] @ List.map (fun k -> `Commit k) parents + + let default_pred_branch t b = + B.Branch.find (branch_t t) b >|= function + | None -> + [%log.debug "%a: not found" pp_branch b]; + [] + | Some b -> [ `Commit b ] + + let iter ?cache_size ~min ~max ?edge ?(branch = ignore_lwt) + ?(commit = ignore_lwt) ?(node = ignore_lwt) ?(contents = ignore_lwt) + ?(skip_branch = return_false) ?(skip_commit = return_false) + ?(skip_node = return_false) ?(skip_contents = return_false) + ?(pred_branch = default_pred_branch) + ?(pred_commit = default_pred_commit) ?(pred_node = default_pred_node) + ?(pred_contents = default_pred_contents) ?(rev = true) t = + let node = function + | `Commit x -> commit x + | `Node x -> node x + | `Contents x -> contents x + | `Branch x -> branch x + in + let skip = function + | `Commit x -> skip_commit x + | `Node x -> skip_node x + | `Contents x -> skip_contents x + | `Branch x -> skip_branch x + in + let pred = function + | `Commit x -> pred_commit t x + | `Node x -> pred_node t x + | `Contents x -> pred_contents t x + | `Branch x -> pred_branch t x + in + KGraph.iter ?cache_size ~pred ~min ~max ~node ?edge ~skip ~rev () + + let breadth_first_traversal ?cache_size ~max ?(branch = ignore_lwt) + ?(commit = ignore_lwt) ?(node = ignore_lwt) ?(contents = ignore_lwt) + ?(pred_branch = default_pred_branch) + ?(pred_commit = default_pred_commit) ?(pred_node = default_pred_node) + ?(pred_contents = default_pred_contents) t = + let node = function + | `Commit x -> commit x + | `Node x -> node x + | `Contents x -> contents x + | `Branch x -> branch x + in + let pred = function + | `Commit x -> pred_commit t x + | `Node x -> pred_node t x + | `Contents x -> pred_contents t x + | `Branch x -> pred_branch t x + in + KGraph.breadth_first_traversal ?cache_size ~pred ~max ~node () + end + + type t = { + repo : Repo.t; + head_ref : head_ref; + mutable tree : (commit * tree) option; + (* cache for the store tree *) + lock : Lwt_mutex.t; + } + + let repo t = t.repo + let branch_store t = Repo.branch_t t.repo + let commit_store t = Repo.commit_t t.repo + + let status t = + match t.head_ref with + | `Branch b -> `Branch b + | `Head h -> ( match !h with None -> `Empty | Some c -> `Commit c) + + let head_ref t = + match t.head_ref with + | `Branch t -> `Branch t + | `Head h -> ( match !h with None -> `Empty | Some h -> `Head h) + + let branch t = + match head_ref t with + | `Branch t -> Lwt.return_some t + | `Empty | `Head _ -> Lwt.return_none + + let err_no_head s = Fmt.kstr Lwt.fail_invalid_arg "Irmin.%s: no head" s + + let retry_merge name fn = + let rec aux i = + fn () >>= function + | Error _ as c -> Lwt.return c + | Ok true -> Merge.ok () + | Ok false -> + [%log.debug "Irmin.%s: conflict, retrying (%d)." name i]; + aux (i + 1) + in + aux 1 + + let of_ref repo head_ref = + let lock = Lwt_mutex.create () in + Lwt.return { lock; head_ref; repo; tree = None } + + let err_invalid_branch t = + let err = Fmt.str "%a is not a valid branch name." pp_branch t in + Lwt.fail (Invalid_argument err) + + let of_branch repo key = + if Branch_store.Key.is_valid key then of_ref repo (`Branch key) + else err_invalid_branch key + + let main repo = of_branch repo Branch_store.Key.main + let master = main + let empty repo = of_ref repo (`Head (ref None)) + let of_commit c = of_ref c.r (`Head (ref (Some c))) + + let skip_key key = + [%log.debug "[watch-key] key %a has not changed" pp_path key]; + Lwt.return_unit + + let changed_key key old_t new_t = + [%log.debug + fun l -> + let pp = Fmt.option ~none:(Fmt.any "") pp_hash in + let old_h = Option.map Tree.hash old_t in + let new_h = Option.map Tree.hash new_t in + l "[watch-key] key %a has changed: %a -> %a" pp_path key pp old_h pp + new_h] + + let with_tree ~key x f = + x >>= function + | None -> skip_key key + | Some x -> + changed_key key None None; + f x + + let lift_tree_diff ~key tree fn = function + | `Removed x -> + with_tree ~key (tree x) @@ fun v -> + changed_key key (Some v) None; + fn @@ `Removed (x, v) + | `Added x -> + with_tree ~key (tree x) @@ fun v -> + changed_key key None (Some v); + fn @@ `Added (x, v) + | `Updated (x, y) -> ( + assert (not (Commit.equal x y)); + let* vx = tree x in + let* vy = tree y in + match (vx, vy) with + | None, None -> skip_key key + | None, Some vy -> + changed_key key None (Some vy); + fn @@ `Added (y, vy) + | Some vx, None -> + changed_key key (Some vx) None; + fn @@ `Removed (x, vx) + | Some vx, Some vy -> + if Tree.equal vx vy then skip_key key + else ( + changed_key key (Some vx) (Some vy); + fn @@ `Updated ((x, vx), (y, vy)))) + + let head t = + let h = + match head_ref t with + | `Head key -> Lwt.return_some key + | `Empty -> Lwt.return_none + | `Branch name -> ( + Branch_store.find (branch_store t) name >>= function + | None -> Lwt.return_none + | Some k -> Commit.of_key t.repo k) + in + let+ h = h in + [%log.debug "Head.find -> %a" Fmt.(option Commit.pp_key) h]; + h + + let tree_and_head t = + head t >|= function + | None -> None + | Some h -> ( + match t.tree with + | Some (o, t) when Commit.equal o h -> Some (o, t) + | _ -> + t.tree <- None; + + (* the tree cache needs to be invalidated *) + let tree = Tree.import_no_check (repo t) (`Node (Commit.node h)) in + t.tree <- Some (h, tree); + Some (h, tree)) + + let tree t = + tree_and_head t >|= function + | None -> Tree.empty () + | Some (_, tree) -> (tree :> tree) + + let lift_head_diff repo fn = function + | `Removed x -> ( + Commit.of_key repo x >>= function + | None -> Lwt.return_unit + | Some x -> fn (`Removed x)) + | `Updated (x, y) -> ( + let* x = Commit.of_key repo x in + let* y = Commit.of_key repo y in + match (x, y) with + | None, None -> Lwt.return_unit + | Some x, None -> fn (`Removed x) + | None, Some y -> fn (`Added y) + | Some x, Some y -> fn (`Updated (x, y))) + | `Added x -> ( + Commit.of_key repo x >>= function + | None -> Lwt.return_unit + | Some x -> fn (`Added x)) + + let watch t ?init fn = + branch t >>= function + | None -> failwith "watch a detached head: TODO" + | Some name0 -> + let init = + match init with + | None -> None + | Some head0 -> Some [ (name0, head0.key) ] + in + let+ key = + Branch_store.watch (branch_store t) ?init (fun name head -> + if equal_branch name0 name then lift_head_diff t.repo fn head + else Lwt.return_unit) + in + fun () -> Branch_store.unwatch (branch_store t) key + + let watch_key t key ?init fn = + [%log.debug "watch-key %a" pp_path key]; + let tree c = Tree.find_tree (Commit.tree c) key in + watch t ?init (lift_tree_diff ~key tree fn) + + module Head = struct + let list = Repo.heads + let find = head + + let get t = + find t >>= function None -> err_no_head "head" | Some k -> Lwt.return k + + let set t c = + match t.head_ref with + | `Head h -> + h := Some c; + Lwt.return_unit + | `Branch name -> Branch_store.set (branch_store t) name c.key + + let test_and_set_unsafe t ~test ~set = + match t.head_ref with + | `Head head -> + (* [head] is protected by [t.lock]. *) + if Commit.equal_opt !head test then ( + head := set; + Lwt.return_true) + else Lwt.return_false + | `Branch name -> + let h = function None -> None | Some c -> Some c.key in + Branch_store.test_and_set (branch_store t) name ~test:(h test) + ~set:(h set) + + let test_and_set t ~test ~set = + Lwt_mutex.with_lock t.lock (fun () -> test_and_set_unsafe t ~test ~set) + + let fast_forward t ?max_depth ?n new_head = + let return x = if x then Ok () else Error (`Rejected :> ff_error) in + find t >>= function + | None -> test_and_set t ~test:None ~set:(Some new_head) >|= return + | Some old_head -> ( + [%log.debug + "fast-forward-head old=%a new=%a" Commit.pp_hash old_head + Commit.pp_hash new_head]; + if Commit.equal new_head old_head then + (* we only update if there is a change *) + Lwt.return (Error `No_change) + else + Commits.lcas (commit_store t) ?max_depth ?n new_head.key + old_head.key + >>= function + | Ok [ x ] when equal_commit_key x old_head.key -> + (* we only update if new_head > old_head *) + test_and_set t ~test:(Some old_head) ~set:(Some new_head) + >|= return + | Ok _ -> Lwt.return (Error `Rejected) + | Error e -> Lwt.return (Error (e :> ff_error))) + + (* Merge two commits: + - Search for common ancestors + - Perform recursive 3-way merges *) + let three_way_merge t ?max_depth ?n ~info c1 c2 = + B.Repo.batch (repo t) @@ fun _ _ commit_t -> + Commits.three_way_merge commit_t ?max_depth ?n ~info c1.key c2.key + + (* FIXME: we might want to keep the new commit in case of conflict, + and use it as a base for the next merge. *) + let merge ~into:t ~info ?max_depth ?n c1 = + [%log.debug "merge_head"]; + let aux () = + let* head = head t in + match head with + | None -> test_and_set_unsafe t ~test:head ~set:(Some c1) >>= Merge.ok + | Some c2 -> + three_way_merge t ~info ?max_depth ?n c1 c2 >>=* fun c3 -> + let* c3 = Commit.of_key t.repo c3 in + test_and_set_unsafe t ~test:head ~set:c3 >>= Merge.ok + in + Lwt_mutex.with_lock t.lock (fun () -> retry_merge "merge_head" aux) + end + + (* Retry an operation until the optimistic lock is happy. Ensure + that the operation is done at least once. *) + let retry ~retries fn = + let done_once = ref false in + let rec aux i = + if !done_once && i > retries then + Lwt.return (Error (`Too_many_retries retries)) + else + fn () >>= function + | Ok (c, true) -> Lwt.return (Ok c) + | Error e -> Lwt.return (Error e) + | Ok (_, false) -> + done_once := true; + aux (i + 1) + in + aux 0 + + let root_tree = function + | `Node _ as n -> Tree.v n + | `Contents _ -> assert false + + let add_commit t old_head ((c, _) as tree) = + match t.head_ref with + | `Head head -> + Lwt_mutex.with_lock t.lock (fun () -> + if not (Commit.equal_opt old_head !head) then Lwt.return_false + else ( + (* [head] is protected by [t.lock] *) + head := Some c; + t.tree <- Some tree; + Lwt.return_true)) + | `Branch name -> + (* concurrent handlers and/or process can modify the + branch. Need to check that we are still working on the same + head. *) + let test = match old_head with None -> None | Some c -> Some c.key in + let set = Some c.key in + let+ r = Branch_store.test_and_set (branch_store t) name ~test ~set in + if r then t.tree <- Some tree; + r + + let pp_write_error ppf = function + | `Conflict e -> Fmt.pf ppf "Got a conflict: %s" e + | `Too_many_retries i -> + Fmt.pf ppf + "Failure after %d attempts to retry the operation: Too many attempts." + i + | `Test_was t -> + Fmt.pf ppf "Test-and-set failed: got %a when reading the store" + Fmt.(Dump.option pp_tree) + t + + let write_error e : ('a, write_error) result Lwt.t = Lwt.return (Error e) + let err_test v = write_error (`Test_was v) + + type snapshot = { + head : commit option; + root : tree; + tree : tree option; + (* the subtree used by the transaction *) + parents : commit list; + } + + let snapshot t key = + tree_and_head t >>= function + | None -> + Lwt.return + { head = None; root = Tree.empty (); tree = None; parents = [] } + | Some (c, root) -> + let root = (root :> tree) in + let+ tree = Tree.find_tree root key in + { head = Some c; root; tree; parents = [ c ] } + + let same_tree x y = + match (x, y) with + | None, None -> true + | None, _ | _, None -> false + | Some x, Some y -> Tree.equal x y + + (* Update the store with a new commit. Ensure the no commit becomes orphan + in the process. *) + let update ?(clear = true) ?(allow_empty = false) ~info ?parents t key + merge_tree f = + let* s = snapshot t key in + (* this might take a very long time *) + let* new_tree = f s.tree in + (* if no change and [allow_empty = true] then, do nothing *) + if same_tree s.tree new_tree && (not allow_empty) && s.head <> None then + Lwt.return (Ok (None, true)) + else + merge_tree s.root key ~current_tree:s.tree ~new_tree >>= function + | Error e -> Lwt.return (Error e) + | Ok root -> + let info = info () in + let parents = match parents with None -> s.parents | Some p -> p in + let parents = List.map Commit.key parents in + let* c = Commit.v ~clear (repo t) ~info ~parents root in + let* r = add_commit t s.head (c, root_tree (Tree.destruct root)) in + Lwt.return (Ok (Some c, r)) + + let ok x = Ok x + + let fail name = function + | Ok x -> Lwt.return x + | Error e -> Fmt.kstr Lwt.fail_with "%s: %a" name pp_write_error e + + let set_tree_once root key ~current_tree:_ ~new_tree = + match new_tree with + | None -> Tree.remove root key >|= ok + | Some tree -> Tree.add_tree root key tree >|= ok + + let ignore_commit + (c : (commit option, [> `Too_many_retries of int ]) result Lwt.t) = + Lwt_result.map (fun _ -> ()) c + + let set_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t k v = + [%log.debug "set %a" pp_path k]; + ignore_commit + @@ retry ~retries + @@ fun () -> + update t k ?clear ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> + Lwt.return_some v + + let set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k v = + set_tree ?clear ?retries ?allow_empty ?parents ~info t k v + >>= fail "set_exn" + + let remove ?clear ?(retries = 13) ?allow_empty ?parents ~info t k = + [%log.debug "debug %a" pp_path k]; + ignore_commit + @@ retry ~retries + @@ fun () -> + update t k ?clear ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> + Lwt.return_none + + let remove_exn ?clear ?retries ?allow_empty ?parents ~info t k = + remove ?clear ?retries ?allow_empty ?parents ~info t k >>= fail "remove_exn" + + let set ?clear ?retries ?allow_empty ?parents ~info t k v = + let v = Tree.of_contents v in + set_tree t k ?clear ?retries ?allow_empty ?parents ~info v + + let set_exn ?clear ?retries ?allow_empty ?parents ~info t k v = + set t k ?clear ?retries ?allow_empty ?parents ~info v >>= fail "set_exn" + + let test_and_set_tree_once ~test root key ~current_tree ~new_tree = + match (test, current_tree) with + | None, None -> set_tree_once root key ~new_tree ~current_tree + | None, _ | _, None -> err_test current_tree + | Some test, Some v -> + if Tree.equal test v then set_tree_once root key ~new_tree ~current_tree + else err_test current_tree + + let test_set_and_get_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t + k ~test ~set = + [%log.debug "test-and-set %a" pp_path k]; + retry ~retries @@ fun () -> + update t k ?clear ?allow_empty ?parents ~info (test_and_set_tree_once ~test) + @@ fun _tree -> Lwt.return set + + let test_set_and_get_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k + ~test ~set = + test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test + ~set + >>= fail "test_set_and_get_tree_exn" + + let test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test + ~set = + let test = Option.map Tree.of_contents test in + let set = Option.map Tree.of_contents set in + test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test + ~set + + let test_set_and_get_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test + ~set = + test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set + >>= fail "test_set_and_get_exn" + + let test_and_set_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t k + ~test ~set = + [%log.debug "test-and-set %a" pp_path k]; + ignore_commit + @@ test_set_and_get_tree ~retries ?clear ?allow_empty ?parents ~info t k + ~test ~set + + let test_and_set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k + ~test ~set = + test_and_set_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set + >>= fail "test_and_set_tree_exn" + + let test_and_set ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set = + ignore_commit + @@ test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test + ~set + + let test_and_set_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test + ~set = + test_and_set ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set + >>= fail "test_and_set_exn" + + let merge_once ~old root key ~current_tree ~new_tree = + let old = Merge.promise old in + Merge.f (Merge.option Tree.merge) ~old current_tree new_tree >>= function + | Ok tr -> set_tree_once root key ~new_tree:tr ~current_tree + | Error e -> write_error (e :> write_error) + + let merge_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info ~old t k + tree = + [%log.debug "merge %a" pp_path k]; + ignore_commit + @@ retry ~retries + @@ fun () -> + update t k ?clear ?allow_empty ?parents ~info (merge_once ~old) + @@ fun _tree -> Lwt.return tree + + let merge_tree_exn ?clear ?retries ?allow_empty ?parents ~info ~old t k tree = + merge_tree ?clear ?retries ?allow_empty ?parents ~info ~old t k tree + >>= fail "merge_tree_exn" + + let merge ?clear ?retries ?allow_empty ?parents ~info ~old t k v = + let old = Option.map Tree.of_contents old in + let v = Option.map Tree.of_contents v in + merge_tree ?clear ?retries ?allow_empty ?parents ~info ~old t k v + + let merge_exn ?clear ?retries ?allow_empty ?parents ~info ~old t k v = + merge ?clear ?retries ?allow_empty ?parents ~info ~old t k v + >>= fail "merge_exn" + + let mem t k = tree t >>= fun tree -> Tree.mem tree k + let mem_tree t k = tree t >>= fun tree -> Tree.mem_tree tree k + let find_all t k = tree t >>= fun tree -> Tree.find_all tree k + let find t k = tree t >>= fun tree -> Tree.find tree k + let get t k = tree t >>= fun tree -> Tree.get tree k + let find_tree t k = tree t >>= fun tree -> Tree.find_tree tree k + let get_tree t k = tree t >>= fun tree -> Tree.get_tree tree k + + let key t k = + find_tree t k >|= function + | None -> None + | Some tree -> ( + match Tree.key tree with + | Some (`Contents (key, _)) -> Some (`Contents key) + | Some (`Node key) -> Some (`Node key) + | None -> None) + + let hash t k = + find_tree t k >|= function + | None -> None + | Some tree -> Some (Tree.hash tree) + + let get_all t k = tree t >>= fun tree -> Tree.get_all tree k + let list t k = tree t >>= fun tree -> Tree.list tree k + let kind t k = tree t >>= fun tree -> Tree.kind tree k + + let with_tree ?clear ?(retries = 13) ?allow_empty ?parents + ?(strategy = `Test_and_set) ~info t key f = + let done_once = ref false in + let rec aux n old_tree = + [%log.debug "with_tree %a (%d/%d)" pp_path key n retries]; + if !done_once && n > retries then write_error (`Too_many_retries retries) + else + let* new_tree = f old_tree in + match (strategy, new_tree) with + | `Set, Some tree -> + set_tree ?clear t key ~retries ?allow_empty ?parents tree ~info + | `Set, None -> remove ?clear t key ~retries ?allow_empty ~info ?parents + | `Test_and_set, _ -> ( + test_and_set_tree ?clear t key ~retries ?allow_empty ?parents ~info + ~test:old_tree ~set:new_tree + >>= function + | Error (`Test_was tr) when retries > 0 && n <= retries -> + done_once := true; + aux (n + 1) tr + | e -> Lwt.return e) + | `Merge, _ -> ( + merge_tree ?clear ~old:old_tree ~retries ?allow_empty ?parents ~info + t key new_tree + >>= function + | Ok _ as x -> Lwt.return x + | Error (`Conflict _) when retries > 0 && n <= retries -> + done_once := true; + + (* use the store's current tree as the new 'old store' *) + let* old_tree = + tree_and_head t >>= function + | None -> Lwt.return_none + | Some (_, tr) -> Tree.find_tree (tr :> tree) key + in + aux (n + 1) old_tree + | Error e -> write_error e) + in + let* old_tree = find_tree t key in + aux 0 old_tree + + let with_tree_exn ?clear ?retries ?allow_empty ?parents ?strategy ~info f t + key = + with_tree ?clear ?retries ?allow_empty ?strategy ?parents ~info f t key + >>= fail "with_tree_exn" + + let clone ~src ~dst = + let* () = + Head.find src >>= function + | None -> Branch_store.remove (branch_store src) dst + | Some h -> Branch_store.set (branch_store src) dst h.key + in + of_branch (repo src) dst + + let return_lcas r = function + | Error _ as e -> Lwt.return e + | Ok commits -> + Lwt_list.filter_map_p (Commit.of_key r) commits >|= Result.ok + + let lcas ?max_depth ?n t1 t2 = + let* h1 = Head.get t1 in + let* h2 = Head.get t2 in + Commits.lcas (commit_store t1) ?max_depth ?n h1.key h2.key + >>= return_lcas t1.repo + + let lcas_with_commit t ?max_depth ?n c = + let* h = Head.get t in + Commits.lcas (commit_store t) ?max_depth ?n h.key c.key + >>= return_lcas t.repo + + let lcas_with_branch t ?max_depth ?n b = + let* h = Head.get t in + let* head = Head.get { t with head_ref = `Branch b } in + Commits.lcas (commit_store t) ?max_depth ?n h.key head.key + >>= return_lcas t.repo + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + + let merge_with_branch t ~info ?max_depth ?n other = + [%log.debug "merge_with_branch %a" pp_branch other]; + Branch_store.find (branch_store t) other >>= function + | None -> + Fmt.kstr Lwt.fail_invalid_arg + "merge_with_branch: %a is not a valid branch ID" pp_branch other + | Some c -> ( + Commit.of_key t.repo c >>= function + | None -> Lwt.fail_invalid_arg "invalid commit" + | Some c -> Head.merge ~into:t ~info ?max_depth ?n c) + + let merge_with_commit t ~info ?max_depth ?n other = + Head.merge ~into:t ~info ?max_depth ?n other + + let merge_into ~into ~info ?max_depth ?n t = + [%log.debug "merge"]; + match head_ref t with + | `Branch name -> merge_with_branch into ~info ?max_depth ?n name + | `Head h -> merge_with_commit into ~info ?max_depth ?n h + | `Empty -> Merge.ok () + + module History = OCamlGraph.Persistent.Digraph.ConcreteBidirectional (struct + type t = commit + + let hash h = B.Hash.short_hash (Commit.hash h) + let compare_key = Type.(unstage (compare B.Commit.Key.t)) + let compare x y = compare_key x.key y.key + let equal x y = equal_commit_key x.key y.key + end) + + module Gmap = struct + module Src = KGraph + + module Dst = struct + include History + + let empty () = empty + end + + let filter_map f g = + let t = Dst.empty () in + if Src.nb_vertex g = 1 then + match Src.vertex g with + | [ v ] -> ( + f v >|= function Some v -> Dst.add_vertex t v | None -> t) + | _ -> assert false + else + Src.fold_edges + (fun x y t -> + let* t = t in + let* x = f x in + let+ y = f y in + match (x, y) with + | Some x, Some y -> + let t = Dst.add_vertex t x in + let t = Dst.add_vertex t y in + Dst.add_edge t x y + | _ -> t) + g (Lwt.return t) + end + + let history ?depth ?(min = []) ?(max = []) t = + [%log.debug "history"]; + let pred = function + | `Commit k -> + Commits.parents (commit_store t) k + >>= Lwt_list.filter_map_p (Commit.of_key t.repo) + >|= fun parents -> List.map (fun x -> `Commit x.key) parents + | _ -> Lwt.return_nil + in + let* max = Head.find t >|= function Some h -> [ h ] | None -> max in + let max = List.map (fun k -> `Commit k.key) max in + let min = List.map (fun k -> `Commit k.key) min in + let* g = Gmap.Src.closure ?depth ~min ~max ~pred () in + Gmap.filter_map + (function `Commit k -> Commit.of_key t.repo k | _ -> Lwt.return_none) + g + + module Heap = Binary_heap.Make (struct + type t = commit * int + + let compare c1 c2 = + (* [bheap] operates on miminums, we need to invert the comparison. *) + -Int64.compare + (Info.date (Commit.info (fst c1))) + (Info.date (Commit.info (fst c2))) + end) + + let last_modified ?depth ?(n = 1) t key = + [%log.debug + "last_modified depth=%a n=%d key=%a" + Fmt.(Dump.option pp_int) + depth n pp_path key]; + let repo = repo t in + let* commit = Head.get t in + let heap = Heap.create ~dummy:(commit, 0) 0 in + let () = Heap.add heap (commit, 0) in + let rec search acc = + if Heap.is_empty heap || List.length acc = n then Lwt.return acc + else + let current, current_depth = Heap.pop_minimum heap in + let parents = Commit.parents current in + let tree = Commit.tree current in + let* current_value = Tree.find tree key in + if List.length parents = 0 then + if current_value <> None then Lwt.return (current :: acc) + else Lwt.return acc + else + let max_depth = + match depth with + | Some depth -> current_depth >= depth + | None -> false + in + let* found = + Lwt_list.for_all_p + (fun hash -> + Commit.of_key repo hash >>= function + | Some commit -> ( + let () = + if not max_depth then + Heap.add heap (commit, current_depth + 1) + in + let tree = Commit.tree commit in + let+ e = Tree.find tree key in + match (e, current_value) with + | Some x, Some y -> not (equal_contents x y) + | Some _, None -> true + | None, Some _ -> true + | _, _ -> false) + | None -> Lwt.return_false) + parents + in + if found then search (current :: acc) else search acc + in + search [] + + module Branch = struct + include B.Branch.Key + + let mem t = B.Branch.mem (B.Repo.branch_t t) + + let find t br = + B.Branch.find (Repo.branch_t t) br >>= function + | None -> Lwt.return_none + | Some h -> Commit.of_key t h + + let set t br h = B.Branch.set (B.Repo.branch_t t) br h.key + let remove t = B.Branch.remove (B.Repo.branch_t t) + let list = Repo.branches + + let watch t k ?init f = + let init = match init with None -> None | Some h -> Some h.key in + let+ w = + B.Branch.watch_key (Repo.branch_t t) k ?init (lift_head_diff t f) + in + fun () -> Branch_store.unwatch (Repo.branch_t t) w + + let watch_all t ?init f = + let init = + match init with + | None -> None + | Some i -> Some (List.map (fun (k, v) -> (k, v.key)) i) + in + let f k v = lift_head_diff t (f k) v in + let+ w = B.Branch.watch (Repo.branch_t t) ?init f in + fun () -> Branch_store.unwatch (Repo.branch_t t) w + + let err_not_found k = + Fmt.kstr invalid_arg "Branch.get: %a not found" pp_branch k + + let get t k = + find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + + let pp = pp_branch + end + + module Status = struct + type t = [ `Empty | `Branch of branch | `Commit of commit ] + + let t r = + let open Type in + variant "status" (fun empty branch commit -> function + | `Empty -> empty | `Branch b -> branch b | `Commit c -> commit c) + |~ case0 "empty" `Empty + |~ case1 "branch" Branch.t (fun b -> `Branch b) + |~ case1 "commit" (Commit.t r) (fun c -> `Commit c) + |> sealv + + let pp ppf = function + | `Empty -> Fmt.string ppf "empty" + | `Branch b -> pp_branch ppf b + | `Commit c -> pp_hash ppf (Commit_key.to_hash c.key) + end + + let commit_t = Commit.t +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..09ba421064 --- /dev/null +++ b/src/irmin-lwt/core/store_intf.ml @@ -0,0 +1,1251 @@ +(* + * 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 Make (B : Backend.S) : + Generic_key.S + with module Schema = B.Schema + and type slice = B.Slice.t + and type repo = B.Repo.t + and type contents_key = B.Contents.key + and type node_key = B.Node.key + and type commit_key = B.Commit.key + and module Backend = B + + 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..8485c2f65e --- /dev/null +++ b/src/irmin-lwt/core/store_properties.ml @@ -0,0 +1,19 @@ +(* + * 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 + +exception 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..513c72b689 --- /dev/null +++ b/src/irmin-lwt/core/sync.ml @@ -0,0 +1,221 @@ +(* + * 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..7090c53e93 --- /dev/null +++ b/src/irmin-lwt/core/tree.ml @@ -0,0 +1,2833 @@ +(* + * 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 +include Tree_intf + +let src = Logs.Src.create "irmin.tree" ~doc:"Persistent lazy trees for Irmin" + +module Log = (val Logs.src_log src : Logs.LOG) + +type fuzzy_bool = False | True | Maybe +type ('a, 'r) cont = ('a -> 'r) -> 'r +type ('a, 'r) cont_lwt = ('a, 'r Lwt.t) cont + +let ok x = Lwt.return (Ok 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 [@tailcall]) t1 t2 + | x -> + if x < 0 then ( + f k1 (`Left v1); + (aux [@tailcall]) t1 l2) + else ( + f k2 (`Right v2); + (aux [@tailcall]) l1 t2)) + in + aux l1 l2 + +(* assume l1 and l2 are key-sorted *) +let alist_iter2_lwt compare_k f l1 l2 = + let l3 = ref [] in + alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; + Lwt_list.iter_s (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !l3) + +exception Backend_invariant_violation of string +exception Assertion_failure of string + +let backend_invariant_violation fmt = + Fmt.kstr (fun s -> raise (Backend_invariant_violation s)) fmt + +let assertion_failure fmt = Fmt.kstr (fun s -> raise (Assertion_failure s)) fmt + +module Make (P : Backend.S) = struct + 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; + } + [@@deriving irmin] + + let dump_counters ppf t = Type.pp_json ~minify:false counters_t ppf t + + let fresh_counters () = + { + contents_hash = 0; + contents_add = 0; + contents_find = 0; + contents_mem = 0; + node_hash = 0; + node_mem = 0; + node_index = 0; + node_add = 0; + node_find = 0; + node_val_v = 0; + node_val_find = 0; + node_val_list = 0; + } + + let reset_counters t = + t.contents_hash <- 0; + t.contents_add <- 0; + t.contents_find <- 0; + t.contents_mem <- 0; + t.node_hash <- 0; + t.node_mem <- 0; + t.node_index <- 0; + t.node_add <- 0; + t.node_find <- 0; + t.node_val_v <- 0; + t.node_val_find <- 0; + t.node_val_list <- 0 + + let cnt = fresh_counters () + + module Path = struct + include P.Node.Path + + let fold_right t ~f ~init = + let steps = map t Fun.id in + List.fold_right f steps init + end + + module Metadata = P.Node.Metadata + module Irmin_proof = Proof + module Tree_proof = Proof.Make (P.Contents.Val) (P.Hash) (Path) (Metadata) + module Env = Proof.Env (P) (Tree_proof) + + let merge_env x y = + match (Env.is_empty x, Env.is_empty y) with + | true, _ -> Ok y + | _, true -> Ok x + | false, false -> Error (`Conflict "merge env") + + module Hashes = Hash.Set.Make (P.Hash) + + module StepMap = struct + module X = struct + type t = Path.step [@@deriving irmin ~compare] + end + + include Map.Make (X) + + let stdlib_merge = merge + + include Merge.Map (X) + + let to_array m = + let length = cardinal m in + if length = 0 then [||] + else + let arr = Array.make length (choose m) in + let (_ : int) = + fold + (fun k v i -> + arr.(i) <- (k, v); + i + 1) + m 0 + in + arr + end + + type metadata = Metadata.t [@@deriving irmin ~equal] + type path = Path.t [@@deriving irmin ~pp] + type hash = P.Hash.t [@@deriving irmin ~pp ~equal ~compare] + type step = Path.step [@@deriving irmin ~pp ~compare] + type contents = P.Contents.Val.t [@@deriving irmin ~equal ~pp] + type repo = P.Repo.t + type marks = Hashes.t + + type error = + [ `Dangling_hash of hash | `Pruned_hash of hash | `Portable_value ] + + type 'a or_error = ('a, error) result + 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 ] + [@@deriving irmin] + + let dummy_marks = Hashes.create ~initial_slots:0 () + let empty_marks () = Hashes.create ~initial_slots:39 () + + exception Pruned_hash of { context : string; hash : hash } + exception Dangling_hash of { context : string; hash : hash } + exception Portable_value of { context : string } + + let () = + Printexc.register_printer (function + | Dangling_hash { context; hash } -> + Some + (Fmt.str "Irmin.Tree.%s: encountered dangling hash %a" context + pp_hash hash) + | Pruned_hash { context; hash } -> + Some + (Fmt.str "Irmin.Tree.%s: encountered pruned hash %a" context pp_hash + hash) + | Portable_value { context } -> + Some + (Fmt.str "Irmin.Tree.%s: unsupported operation on portable tree." + context) + | _ -> None) + + let err_pruned_hash h = Error (`Pruned_hash h) + let err_dangling_hash h = Error (`Dangling_hash h) + let err_portable_value = Error `Portable_value + let pruned_hash_exn context hash = raise (Pruned_hash { context; hash }) + let portable_value_exn context = raise (Portable_value { context }) + + let get_ok : type a. string -> a or_error -> a = + fun context -> function + | Ok x -> x + | Error (`Pruned_hash hash) -> pruned_hash_exn context hash + | Error (`Dangling_hash hash) -> raise (Dangling_hash { context; hash }) + | Error `Portable_value -> portable_value_exn context + + type 'key ptr_option = Key of 'key | Hash of hash | Ptr_none + (* NOTE: given the choice, we prefer caching [Key] over [Hash] as it can + be used to avoid storing duplicate contents values on export. *) + + module Contents = struct + type key = P.Contents.Key.t [@@deriving irmin] + type v = Key of repo * key | Value of contents | Pruned of hash + type nonrec ptr_option = key ptr_option + + type info = { + mutable ptr : ptr_option; + mutable value : contents option; + env : Env.t; + } + + type t = { mutable v : v; info : info } + + let info_is_empty i = i.ptr = Ptr_none && i.value = None + + let v = + let open Type in + variant "Node.Contents.v" (fun key value pruned (v : v) -> + match v with + | Key (_, x) -> key x + | Value v -> value v + | Pruned h -> pruned h) + |~ case1 "key" P.Contents.Key.t (fun _ -> assert false) + |~ case1 "value" P.Contents.Val.t (fun v -> Value v) + |~ case1 "pruned" hash_t (fun h -> Pruned h) + |> sealv + + let clear_info i = + if not (info_is_empty i) then ( + i.value <- None; + i.ptr <- Ptr_none) + + let clear t = clear_info t.info + + let of_v ~env (v : v) = + let ptr, value = + match v with + | Key (_, k) -> ((Key k : ptr_option), None) + | Value v -> (Ptr_none, Some v) + | Pruned _ -> (Ptr_none, None) + in + let info = { ptr; value; env } in + { v; info } + + let export ?clear:(c = true) repo t k = + let ptr = t.info.ptr in + if c then clear t; + match (t.v, ptr) with + | Key (repo', _), (Ptr_none | Hash _) -> + if repo != repo' then t.v <- Key (repo, k) + | Key (repo', _), Key k -> if repo != repo' then t.v <- Key (repo, k) + | Value _, (Ptr_none | Hash _) -> t.v <- Key (repo, k) + | Value _, Key k -> t.v <- Key (repo, k) + | Pruned _, _ -> + (* The main export function never exports a pruned position. *) + assert false + + let of_value c = of_v (Value c) + let of_key repo k = of_v (Key (repo, k)) + let pruned h = of_v (Pruned h) + + let cached_hash t = + match (t.v, t.info.ptr) with + | Key (_, k), _ -> Some (P.Contents.Key.to_hash k) + | Value _, Key k -> Some (P.Contents.Key.to_hash k) + | Pruned h, _ -> Some h + | Value _, Hash h -> Some h + | Value _, Ptr_none -> None + + let cached_key t = + match (t.v, t.info.ptr) with + | Key (_, k), _ -> Some k + | (Value _ | Pruned _), Key k -> Some k + | (Value _ | Pruned _), (Hash _ | Ptr_none) -> None + + let cached_value t = + match (t.v, t.info.value) with + | Value v, None -> Some v + | (Key _ | Value _ | Pruned _), (Some _ as v) -> v + | (Key _ | Pruned _), None -> ( + match cached_hash t with + | None -> None + | Some h -> ( + match Env.find_contents t.info.env h with + | None -> None + | Some c -> Some c)) + + let hash ?(cache = true) c = + match cached_hash c with + | Some k -> k + | None -> ( + match cached_value c with + | None -> assert false + | Some v -> + cnt.contents_hash <- cnt.contents_hash + 1; + let h = P.Contents.Hash.hash v in + assert (c.info.ptr = Ptr_none); + if cache then c.info.ptr <- Hash h; + h) + + let key t = + match t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None + + let value_of_key ~cache t repo k = + cnt.contents_find <- cnt.contents_find + 1; + let h = P.Contents.Key.to_hash k in + let+ v_opt = P.Contents.find (P.Repo.contents_t repo) k in + Option.iter (Env.add_contents_from_store t.info.env h) v_opt; + match v_opt with + | None -> err_dangling_hash h + | Some v -> + if cache then t.info.value <- v_opt; + Ok v + + let to_value ~cache t = + match cached_value t with + | Some v -> ok v + | None -> ( + match t.v with + | Value _ -> assert false (* [cached_value == None] *) + | Key (repo, k) -> value_of_key ~cache t repo k + | Pruned h -> err_pruned_hash h |> Lwt.return) + + let force = to_value ~cache:true + + let force_exn t = + let+ v = force t in + get_ok "force" v + + let equal (x : t) (y : t) = + x == y + || + match (cached_hash x, cached_hash y) with + | Some x, Some y -> equal_hash x y + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> equal_contents x y + | _ -> equal_hash (hash ~cache:true x) (hash ~cache:true y)) + + let compare (x : t) (y : t) = + if x == y then 0 + else compare_hash (hash ~cache:true x) (hash ~cache:true y) + + let t = + let of_v v = of_v ~env:(Env.empty ()) v in + Type.map ~equal ~compare v of_v (fun t -> t.v) + + let merge : t Merge.t = + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + let+ c = to_value ~cache:true old >|= Option.of_result in + Ok (Some c)) + in + match merge_env x.info.env y.info.env with + | Error _ as e -> Lwt.return e + | Ok env -> ( + let* x = to_value ~cache:true x >|= Option.of_result in + let* y = to_value ~cache:true y >|= Option.of_result in + Merge.(f P.Contents.Val.merge) ~old x y >|= function + | Ok (Some c) -> Ok (of_value ~env c) + | Ok None -> Error (`Conflict "empty contents") + | Error _ as e -> e) + in + Merge.v t f + + let fold ~force ~cache ~path f_value f_tree t acc = + match force with + | `True -> + let* c = to_value ~cache t in + f_value path (get_ok "fold" c) acc >>= f_tree path + | `False skip -> ( + match cached_value t with + | None -> skip path acc + | Some c -> f_value path c acc >>= f_tree path) + end + + module Node = struct + type value = P.Node.Val.t [@@deriving irmin ~equal ~pp] + type key = P.Node.Key.t [@@deriving irmin] + type nonrec ptr_option = key ptr_option + + open struct + module Portable = P.Node_portable + end + + type portable = Portable.t [@@deriving irmin ~equal ~pp] + + (* [elt] is a tree *) + type elt = [ `Node of t | `Contents of Contents.t * Metadata.t ] + and update = Add of elt | Remove + and updatemap = update StepMap.t + and map = elt StepMap.t + + and info = { + mutable value : value option; + mutable map : map option; + mutable ptr : ptr_option; + mutable findv_cache : map option; + mutable length : int Lazy.t option; + env : Env.t; + } + + and v = + | Map of map + | Key of repo * key + | Value of repo * value * updatemap option + | Portable_dirty of portable * updatemap + | Pruned of hash + + and t = { mutable v : v; info : info } + (** For discussion of [t.v]'s states, see {!Tree_intf.S.inspect}. + + [t.info.map] is only populated during a call to [Node.to_map]. *) + + let elt_t (t : t Type.t) : elt Type.t = + let open Type in + variant "Node.value" (fun node contents contents_m -> function + | `Node x -> node x + | `Contents (c, m) -> + if equal_metadata m Metadata.default then contents c + else contents_m (c, m)) + |~ case1 "Node" t (fun x -> `Node x) + |~ case1 "Contents" Contents.t (fun x -> `Contents (x, Metadata.default)) + |~ case1 "Contents-x" (pair Contents.t Metadata.t) (fun x -> `Contents x) + |> sealv + + let stepmap_t : 'a. 'a Type.t -> 'a StepMap.t Type.t = + fun elt -> + let open Type in + let to_map x = + List.fold_left (fun acc (k, v) -> StepMap.add k v acc) StepMap.empty x + in + let of_map m = StepMap.fold (fun k v acc -> (k, v) :: acc) m [] in + map (list (pair Path.step_t elt)) to_map of_map + + let update_t (elt : elt Type.t) : update Type.t = + let open Type in + variant "Node.update" (fun add remove -> function + | Add elt -> add elt | Remove -> remove) + |~ case1 "add" elt (fun elt -> Add elt) + |~ case0 "remove" Remove + |> sealv + + let v_t (elt : elt Type.t) : v Type.t = + let m = stepmap_t elt in + let um = stepmap_t (update_t elt) in + let open Type in + variant "Node.node" (fun map key value pruned portable_dirty -> function + | Map m -> map m + | Key (_, y) -> key y + | Value (_, v, m) -> value (v, m) + | Pruned h -> pruned h + | Portable_dirty (v, m) -> portable_dirty (v, m)) + |~ case1 "map" m (fun m -> Map m) + |~ case1 "key" P.Node.Key.t (fun _ -> assert false) + |~ case1 "value" (pair P.Node.Val.t (option um)) (fun _ -> assert false) + |~ case1 "pruned" hash_t (fun h -> Pruned h) + |~ case1 "portable_dirty" (pair portable_t um) (fun (v, m) -> + Portable_dirty (v, m)) + |> sealv + + let of_v ?length ~env v = + let ptr, map, value = + match v with + | Map m -> (Ptr_none, Some m, None) + | Key (_, k) -> (Key k, None, None) + | Value (_, v, None) -> (Ptr_none, None, Some v) + | Value _ | Portable_dirty _ | Pruned _ -> (Ptr_none, None, None) + in + let findv_cache = None in + let info = { ptr; map; value; findv_cache; env; length } in + { v; info } + + let of_map m = of_v (Map m) + let of_key repo k = of_v (Key (repo, k)) + + let of_value ?length ?updates repo v = + of_v ?length (Value (repo, v, updates)) + + let of_portable_dirty p updates = of_v (Portable_dirty (p, updates)) + let pruned h = of_v (Pruned h) + + let info_is_empty i = + i.map = None && i.value = None && i.findv_cache = None && i.ptr = Ptr_none + + let add_to_findv_cache t step v = + match t.info.findv_cache with + | None -> t.info.findv_cache <- Some (StepMap.singleton step v) + | Some m -> t.info.findv_cache <- Some (StepMap.add step v m) + + let clear_info_fields i = + if not (info_is_empty i) then ( + i.value <- None; + i.map <- None; + i.ptr <- Ptr_none; + i.findv_cache <- None) + + let rec clear_elt ~max_depth depth v = + match v with + | `Contents (c, _) -> if depth + 1 > max_depth then Contents.clear c + | `Node t -> clear ~max_depth (depth + 1) t + + and clear_info ~max_depth ~v depth i = + let clear _ v = clear_elt ~max_depth depth v in + let () = + match v with + | Value (_, _, Some um) -> + StepMap.iter + (fun k -> function Remove -> () | Add v -> clear k v) + um + | Value (_, _, None) | Map _ | Key _ | Portable_dirty _ | Pruned _ -> () + in + let () = + match (v, i.map) with + | Map m, _ | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> + StepMap.iter clear m + | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> () + in + let () = + match i.findv_cache with Some m -> StepMap.iter clear m | None -> () + in + if depth >= max_depth then clear_info_fields i + + and clear ~max_depth depth t = clear_info ~v:t.v ~max_depth depth t.info + + (* export t to the given repo and clear the cache *) + let export ?clear:(c = true) repo t k = + let ptr = t.info.ptr in + if c then clear_info_fields t.info; + match t.v with + | Key (repo', k) -> if repo != repo' then t.v <- Key (repo, k) + | Value _ | Map _ -> ( + match ptr with + | Ptr_none | Hash _ -> t.v <- Key (repo, k) + | Key k -> t.v <- Key (repo, k)) + | Portable_dirty _ | Pruned _ -> + (* The main export function never exports a pruned position. *) + assert false + + module Core_value + (N : Node.Generic_key.Core + with type step := step + and type hash := hash + and type metadata := metadata) + (To_elt : sig + type repo + + val t : env:Env.t -> repo -> N.value -> elt + end) = + struct + let to_map ~cache ~env repo t = + cnt.node_val_list <- cnt.node_val_list + 1; + let entries = N.seq ~cache t in + Seq.fold_left + (fun acc (k, v) -> StepMap.add k (To_elt.t ~env repo v) acc) + StepMap.empty entries + + (** Does [um] empties [v]? + + Gotcha: Some [Remove] entries in [um] might not be in [v]. *) + let is_empty_after_updates ~cache t um = + let any_add = + StepMap.to_seq um + |> Seq.exists (function _, Remove -> false | _, Add _ -> true) + in + if any_add then false + else + let val_is_empty = N.is_empty t in + if val_is_empty then true + else + let remove_count = StepMap.cardinal um in + if (not val_is_empty) && remove_count = 0 then false + else if N.length t > remove_count then false + else ( + (* Starting from this point the function is expensive, but there is + no alternative. *) + cnt.node_val_list <- cnt.node_val_list + 1; + let entries = N.seq ~cache t in + Seq.for_all (fun (step, _) -> StepMap.mem step um) entries) + + let findv ~cache ~env step node repo t = + match N.find ~cache t step with + | None -> None + | Some v -> + let tree = To_elt.t ~env repo v in + if cache then add_to_findv_cache node step tree; + Some tree + + let seq ~env ?offset ?length ~cache repo v = + cnt.node_val_list <- cnt.node_val_list + 1; + let seq = N.seq ?offset ?length ~cache v in + Seq.map (fun (k, v) -> (k, To_elt.t ~env repo v)) seq + end + + module Regular_value = + Core_value + (P.Node.Val) + (struct + type nonrec repo = repo + + let t ~env repo = function + | `Node k -> `Node (of_key ~env repo k) + | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) + end) + + module Portable_value = + Core_value + (P.Node_portable) + (struct + type repo = unit + + let t ~env () = function + | `Node h -> `Node (pruned ~env h) + | `Contents (h, m) -> `Contents (Contents.pruned ~env h, m) + end) + + (** This [Scan] module contains function that scan the content of [t.v] and + [t.info], looking for specific patterns. *) + module Scan = struct + let iter_hash t hit miss miss_arg = + match (t.v, t.info.ptr) with + | Key (_, k), _ -> hit (P.Node.Key.to_hash k) + | (Map _ | Value _ | Portable_dirty _), Key k -> + hit (P.Node.Key.to_hash k) + | Pruned h, _ -> hit h + | (Map _ | Value _ | Portable_dirty _), Hash h -> hit h + | (Map _ | Value _ | Portable_dirty _), Ptr_none -> miss t miss_arg + + let iter_key t hit miss miss_arg = + match (t.v, t.info.ptr) with + | Key (_, k), _ -> hit k + | (Map _ | Value _ | Portable_dirty _ | Pruned _), Key k -> hit k + | (Map _ | Value _ | Portable_dirty _ | Pruned _), (Hash _ | Ptr_none) + -> + miss t miss_arg + + let iter_map t hit miss miss_arg = + match (t.v, t.info.map) with + | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> hit m + | Map m, _ -> hit m + | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> + miss t miss_arg + + let iter_value t hit miss miss_arg = + match (t.v, t.info.value) with + | Value (_, v, None), None -> hit v + | (Map _ | Key _ | Value _ | Portable_dirty _ | Pruned _), Some v -> + hit v + | ( (Map _ | Key _ | Value (_, _, Some _) | Portable_dirty _ | Pruned _), + None ) -> + iter_hash t + (fun h -> + (* The need for [t], [miss] and [miss_arg] allocates a closure *) + match Env.find_node t.info.env h with + | None -> miss t miss_arg + | Some v -> hit v) + miss miss_arg + + let iter_portable t hit miss miss_arg = + match t.v with + | Pruned h -> ( + match Env.find_pnode t.info.env h with + | None -> miss t miss_arg + | Some v -> hit v) + | Map _ | Key _ | Value _ | Portable_dirty _ -> + (* No need to peek in [env]in these cases because [env] + is in practice expected to only hit on [Pruned]. *) + miss t miss_arg + + let iter_repo_key t hit miss miss_arg = + match (t.v, t.info.ptr) with + | Key (repo, k), _ -> hit repo k + | Value (repo, _, _), Key k -> hit repo k + | (Map _ | Portable_dirty _ | Pruned _ | Value _), _ -> miss t miss_arg + + let iter_repo_value t hit miss miss_arg = + match (t.v, t.info.value) with + | Value (repo, v, None), _ -> hit repo v + | (Value (repo, _, _) | Key (repo, _)), Some v -> hit repo v + | (Value (repo, _, _) | Key (repo, _)), None -> + iter_hash t + (fun h -> + match Env.find_node t.info.env h with + | None -> miss t miss_arg + | Some v -> hit repo v) + miss miss_arg + | (Map _ | Portable_dirty _ | Pruned _), _ -> miss t miss_arg + + type node = t + + (** An instance of [t] is expected to be the result of a chain of [to_*] + function calls. + + The [to_*] functions scan a [node] and look for a specific pattern. + The first function in the chain to match a pattern will return the + instance of [t] and ignore the rest of the chain. + + The functions in the chain should be carefuly ordered so that the + computation that follows is as quick as possible (e.g. if the goal is + to convert a [node] to hash, [to_hash] should be checked before + [to_map]). + + [cascade] may be used in order to build chains. *) + + type _ t = + | Hash : hash -> [> `hash ] t + | Map : map -> [> `map ] t + | Value : value -> [> `value ] t + | Value_dirty : (repo * value * updatemap) -> [> `value_dirty ] t + | Portable : portable -> [> `portable ] t + | Portable_dirty : (portable * updatemap) -> [> `portable_dirty ] t + | Pruned : hash -> [> `pruned ] t + | Repo_key : (repo * key) -> [> `repo_key ] t + | Repo_value : (repo * value) -> [> `repo_value ] t + | Any : [> `any ] t + + module View_kind = struct + type _ t = + | Hash : [> `hash ] t + | Map : [> `map ] t + | Value : [> `value ] t + | Value_dirty : [> `value_dirty ] t + | Portable : [> `portable ] t + | Portable_dirty : [> `portable_dirty ] t + | Pruned : [> `pruned ] t + | Repo_key : [> `repo_key ] t + | Repo_value : [> `repo_value ] t + | Any : [> `any ] t + end + + let to_hash t miss = iter_hash t (fun h -> Hash h) miss + let to_map t miss = iter_map t (fun m -> Map m) miss + let to_value t miss = iter_value t (fun v -> Value v) miss + let to_portable t miss = iter_portable t (fun v -> Portable v) miss + + let to_value_dirty t miss miss_arg = + match t.v with + | Value (repo, v, Some um) -> Value_dirty (repo, v, um) + | Map _ | Key _ | Value (_, _, None) | Portable_dirty _ | Pruned _ -> + miss t miss_arg + + let to_portable_dirty t miss miss_arg = + match t.v with + | Portable_dirty (v, um) -> Portable_dirty (v, um) + | Map _ | Key _ | Value _ | Pruned _ -> miss t miss_arg + + let to_pruned t miss miss_arg = + match t.v with + | Pruned h -> Pruned h + | Map _ | Key _ | Value _ | Portable_dirty _ -> miss t miss_arg + + let to_repo_key t miss miss_arg = + iter_repo_key t (fun repo k -> Repo_key (repo, k)) miss miss_arg + + let to_repo_value t miss miss_arg = + iter_repo_value t (fun repo v -> Repo_value (repo, v)) miss miss_arg + + let rec cascade : type k. node -> k View_kind.t list -> k t = + fun t -> function + | [] -> + (* The declared cascade doesn't cover all cases *) + assert false + | x :: xs -> ( + match x with + | Hash -> to_hash t cascade xs + | Map -> to_map t cascade xs + | Value -> to_value t cascade xs + | Value_dirty -> to_value_dirty t cascade xs + | Portable -> to_portable t cascade xs + | Portable_dirty -> to_portable_dirty t cascade xs + | Pruned -> to_pruned t cascade xs + | Repo_key -> to_repo_key t cascade xs + | Repo_value -> to_repo_value t cascade xs + | Any -> Any) + end + + let get_none _ () = None + let cached_hash t = Scan.iter_hash t Option.some get_none () + let cached_key t = Scan.iter_key t Option.some get_none () + let cached_map t = Scan.iter_map t Option.some get_none () + let cached_value t = Scan.iter_value t Option.some get_none () + let cached_portable t = Scan.iter_portable t Option.some get_none () + + let key t = + match t.v with + | Key (_, k) -> Some k + | Map _ | Value _ | Portable_dirty _ | Pruned _ -> None + + (* When computing hashes of nodes, we try to use [P.Node.Val.t] as a + pre-image if possible so that this intermediate value can be cached + within [t.info.value] (in case it is about to be written to the backend). + + This is only possible if all of the child pointers have pre-existing + keys, otherwise we must convert to portable nodes as a fallback. *) + type hash_preimage = Node of P.Node.Val.t | Pnode of Portable.t + type node_value = P.Node.Val.value + type pnode_value = Portable.value + + type hash_preimage_value = + | Node_value of node_value + | Pnode_value of pnode_value + + let weaken_value : node_value -> pnode_value = function + | `Contents (key, m) -> `Contents (P.Contents.Key.to_hash key, m) + | `Node key -> `Node (P.Node.Key.to_hash key) + + let rec hash : type a. cache:bool -> t -> (hash -> a) -> a = + fun ~cache t k -> + let a_of_hashable hash v = + cnt.node_hash <- cnt.node_hash + 1; + let hash = hash v in + assert (t.info.ptr = Ptr_none); + if cache then t.info.ptr <- Hash hash; + k hash + in + match + (Scan.cascade t [ Hash; Value; Value_dirty; Portable_dirty; Map ] + : [ `hash | `value | `value_dirty | `portable_dirty | `map ] Scan.t) + with + | Hash h -> k h + | Value v -> a_of_hashable P.Node.Val.hash_exn v + | Value_dirty (_repo, v, um) -> + hash_preimage_of_updates ~cache t (Node v) um (function + | Node x -> a_of_hashable P.Node.Val.hash_exn x + | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) + | Portable_dirty (p, um) -> + hash_preimage_of_updates ~cache t (Pnode p) um (function + | Node x -> a_of_hashable P.Node.Val.hash_exn x + | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) + | Map m -> + hash_preimage_of_map ~cache t m (function + | Node x -> a_of_hashable P.Node.Val.hash_exn x + | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) + + and hash_preimage_of_map : + type r. cache:bool -> t -> map -> (hash_preimage, r) cont = + fun ~cache t map k -> + cnt.node_val_v <- cnt.node_val_v + 1; + let bindings = StepMap.to_seq map in + let must_build_portable_node = + bindings + |> Seq.exists (fun (_, v) -> + match v with + | `Node n -> Option.is_none (cached_key n) + | `Contents (c, _) -> Option.is_none (Contents.cached_key c)) + in + if must_build_portable_node then + let pnode = + bindings + |> Seq.map (fun (step, v) -> + match v with + | `Contents (c, m) -> (step, `Contents (Contents.hash c, m)) + | `Node n -> hash ~cache n (fun k -> (step, `Node k))) + |> Portable.of_seq + in + k (Pnode pnode) + else + let node = + bindings + |> Seq.map (fun (step, v) -> + match v with + | `Contents (c, m) -> ( + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + (* We checked that all child keys are cached above *) + assert false) + | `Node n -> ( + match cached_key n with + | Some k -> (step, `Node k) + | None -> + (* We checked that all child keys are cached above *) + assert false)) + |> P.Node.Val.of_seq + in + if cache then t.info.value <- Some node; + k (Node node) + + and hash_preimage_value_of_elt : + type r. cache:bool -> elt -> (hash_preimage_value, r) cont = + fun ~cache e k -> + match e with + | `Contents (c, m) -> ( + match Contents.key c with + | Some key -> k (Node_value (`Contents (key, m))) + | None -> k (Pnode_value (`Contents (Contents.hash c, m)))) + | `Node n -> ( + match key n with + | Some key -> k (Node_value (`Node key)) + | None -> hash ~cache n (fun hash -> k (Pnode_value (`Node hash)))) + + and hash_preimage_of_updates : + type r. + cache:bool -> t -> hash_preimage -> updatemap -> (hash_preimage, r) cont + = + fun ~cache t v updates k -> + let updates = StepMap.bindings updates in + let rec aux acc = function + | [] -> + (if cache then + match acc with Node n -> t.info.value <- Some n | Pnode _ -> ()); + k acc + | (k, Add e) :: rest -> + hash_preimage_value_of_elt ~cache e (fun e -> + let acc = + match (acc, e) with + | Node n, Node_value v -> Node (P.Node.Val.add n k v) + | Node n, Pnode_value v -> + Pnode (Portable.add (Portable.of_node n) k v) + | Pnode n, Node_value v -> + Pnode (Portable.add n k (weaken_value v)) + | Pnode n, Pnode_value v -> Pnode (Portable.add n k v) + in + aux acc rest) + | (k, Remove) :: rest -> + let acc = + match acc with + | Node n -> Node (P.Node.Val.remove n k) + | Pnode n -> Pnode (Portable.remove n k) + in + aux acc rest + in + aux v updates + + let hash ~cache k = hash ~cache k (fun x -> x) + + let value_of_key ~cache t repo k = + match cached_value t with + | Some v -> ok v + | None -> ( + cnt.node_find <- cnt.node_find + 1; + let+ v_opt = P.Node.find (P.Repo.node_t repo) k in + let h = P.Node.Key.to_hash k in + let v_opt = Option.map (Env.add_node_from_store t.info.env h) v_opt in + match v_opt with + | None -> err_dangling_hash h + | Some v -> + if cache then t.info.value <- v_opt; + Ok v) + + let to_value ~cache t = + match + (Scan.cascade t [ Value; Repo_key; Any ] + : [ `value | `repo_key | `any ] Scan.t) + with + | Value v -> ok v + | Repo_key (repo, k) -> value_of_key ~cache t repo k + | Any -> ( + match t.v with + | Key _ | Value (_, _, None) -> assert false + | Pruned h -> err_pruned_hash h |> Lwt.return + | Portable_dirty _ -> err_portable_value |> Lwt.return + | Map _ | Value (_, _, Some _) -> + invalid_arg + "Tree.Node.to_value: the supplied node has not been written to \ + disk. Either export it or convert it to a portable value \ + instead.") + + let to_portable_value_aux ~cache ~value_of_key ~return ~bind:( let* ) t = + let ok x = return (Ok x) in + match + (Scan.cascade t + [ + Portable; Value; Repo_key; Portable_dirty; Value_dirty; Map; Pruned; + ] + : [ `portable + | `value + | `repo_key + | `portable_dirty + | `value_dirty + | `map + | `pruned ] + Scan.t) + with + | Portable p -> ok p + | Value v -> ok (P.Node_portable.of_node v) + | Portable_dirty (p, um) -> + hash_preimage_of_updates ~cache t (Pnode p) um (function + | Node _ -> assert false + | Pnode x -> ok x) + | Repo_key (repo, k) -> + let* value_res = value_of_key ~cache t repo k in + Result.map P.Node_portable.of_node value_res |> return + | Value_dirty (_repo, v, um) -> + hash_preimage_of_updates ~cache t (Node v) um (function + | Node x -> ok (Portable.of_node x) + | Pnode x -> ok x) + | Map m -> + hash_preimage_of_map ~cache t m (function + | Node x -> ok (Portable.of_node x) + | Pnode x -> ok x) + | Pruned h -> err_pruned_hash h |> return + + let to_portable_value = + to_portable_value_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind + + let to_map ~cache t = + let of_maps m updates = + let m = + match updates with + | None -> m + | Some updates -> + StepMap.stdlib_merge + (fun _ left right -> + match (left, right) with + | None, None -> assert false + | (Some _ as v), None -> v + | _, Some (Add v) -> Some v + | _, Some Remove -> None) + m updates + in + if cache then t.info.map <- Some m; + m + in + let of_value repo v um = + let env = t.info.env in + let m = Regular_value.to_map ~env ~cache repo v in + of_maps m um + in + let of_portable_value v um = + let env = t.info.env in + let m = Portable_value.to_map ~env ~cache () v in + of_maps m um + in + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> ok m + | Repo_value (repo, v) -> ok (of_value repo v None) + | Repo_key (repo, k) -> ( + value_of_key ~cache t repo k >|= function + | Error _ as e -> e + | Ok v -> Ok (of_value repo v None)) + | Value_dirty (repo, v, um) -> ok (of_value repo v (Some um)) + | Portable p -> ok (of_portable_value p None) + | Portable_dirty (p, um) -> ok (of_portable_value p (Some um)) + | Pruned h -> err_pruned_hash h |> Lwt.return + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 || (Contents.equal c1 c2 && equal_metadata m1 m2) + + let rec elt_equal (x : elt) (y : elt) = + x == y + || + match (x, y) with + | `Contents x, `Contents y -> contents_equal x y + | `Node x, `Node y -> equal x y + | _ -> false + + and map_equal (x : map) (y : map) = StepMap.equal elt_equal x y + + and equal (x : t) (y : t) = + x == y + || + match (cached_hash x, cached_hash y) with + | Some x, Some y -> equal_hash x y + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> equal_value x y + | _ -> ( + match (cached_portable x, cached_portable y) with + | Some x, Some y -> equal_portable x y + | _ -> ( + match (cached_map x, cached_map y) with + | Some x, Some y -> map_equal x y + | _ -> equal_hash (hash ~cache:true x) (hash ~cache:true y)))) + + (* same as [equal] but do not compare in-memory maps + recursively. *) + let maybe_equal (x : t) (y : t) = + if x == y then True + else + match (cached_hash x, cached_hash y) with + | Some x, Some y -> if equal_hash x y then True else False + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> if equal_value x y then True else False + | _ -> ( + match (cached_portable x, cached_portable y) with + | Some x, Some y -> if equal_portable x y then True else False + | _ -> Maybe)) + + let empty () = of_map StepMap.empty ~env:(Env.empty ()) + let empty_hash = hash ~cache:false (empty ()) + let singleton k v = of_map (StepMap.singleton k v) + + let slow_length ~cache t = + match + (Scan.cascade t + [ + Map; Value; Portable; Repo_key; Value_dirty; Portable_dirty; Pruned; + ] + : [ `map + | `value + | `portable + | `repo_key + | `value_dirty + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> StepMap.cardinal m |> Lwt.return + | Value v -> P.Node.Val.length v |> Lwt.return + | Portable p -> P.Node_portable.length p |> Lwt.return + | Repo_key (repo, k) -> + value_of_key ~cache t repo k >|= get_ok "length" >|= P.Node.Val.length + | Value_dirty (_repo, v, um) -> + hash_preimage_of_updates ~cache t (Node v) um (function + | Node x -> P.Node.Val.length x |> Lwt.return + | Pnode x -> P.Node_portable.length x |> Lwt.return) + | Portable_dirty (p, um) -> + hash_preimage_of_updates ~cache t (Pnode p) um (function + | Node _ -> assert false + | Pnode x -> P.Node_portable.length x |> Lwt.return) + | Pruned h -> pruned_hash_exn "length" h + + let length ~cache t = + match t.info.length with + | Some (lazy len) -> Lwt.return len + | None -> + let+ len = slow_length ~cache t in + t.info.length <- Some (Lazy.from_val len); + len + + let is_empty ~cache t = + match + (Scan.cascade t + [ Map; Value; Portable; Hash; Value_dirty; Portable_dirty ] + : [ `map + | `value + | `portable + | `hash + | `value_dirty + | `portable_dirty ] + Scan.t) + with + | Map m -> StepMap.is_empty m + | Value v -> P.Node.Val.is_empty v + | Portable p -> P.Node_portable.is_empty p + | Hash h -> equal_hash h empty_hash + | Value_dirty (_repo, v, um) -> + Regular_value.is_empty_after_updates ~cache v um + | Portable_dirty (p, um) -> + Portable_value.is_empty_after_updates ~cache p um + + let findv_aux ~cache ~value_of_key ~return ~bind:( let* ) ctx t step = + let of_map m = try Some (StepMap.find step m) with Not_found -> None in + let of_value = Regular_value.findv ~cache ~env:t.info.env step t in + let of_portable = Portable_value.findv ~cache ~env:t.info.env step t () in + let of_t () = + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> return (of_map m) + | Repo_value (repo, v) -> return (of_value repo v) + | Repo_key (repo, k) -> + let* v = value_of_key ~cache t repo k in + let v = get_ok ctx v in + return (of_value repo v) + | Value_dirty (repo, v, um) -> ( + match StepMap.find_opt step um with + | Some (Add v) -> return (Some v) + | Some Remove -> return None + | None -> return (of_value repo v)) + | Portable p -> return (of_portable p) + | Portable_dirty (p, um) -> ( + match StepMap.find_opt step um with + | Some (Add v) -> return (Some v) + | Some Remove -> return None + | None -> return (of_portable p)) + | Pruned h -> pruned_hash_exn ctx h + in + match t.info.findv_cache with + | None -> of_t () + | Some m -> ( + match of_map m with None -> of_t () | Some _ as r -> return r) + + let findv = findv_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind + + let seq_of_map ?(offset = 0) ?length m : (step * elt) Seq.t = + let take seq = + match length with None -> seq | Some n -> Seq.take n seq + in + StepMap.to_seq m |> Seq.drop offset |> take + + let seq ?offset ?length ~cache t : (step * elt) Seq.t or_error Lwt.t = + let env = t.info.env in + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> ok (seq_of_map ?offset ?length m) + | Repo_value (repo, v) -> + ok (Regular_value.seq ~env ?offset ?length ~cache repo v) + | Repo_key (repo, k) -> ( + value_of_key ~cache t repo k >>= function + | Error _ as e -> Lwt.return e + | Ok v -> ok (Regular_value.seq ~env ?offset ?length ~cache repo v)) + | Value_dirty _ | Portable_dirty _ -> ( + to_map ~cache t >>= function + | Error _ as e -> Lwt.return e + | Ok m -> ok (seq_of_map ?offset ?length m)) + | Portable p -> ok (Portable_value.seq ~env ?offset ?length ~cache () p) + | Pruned h -> err_pruned_hash h |> Lwt.return + + let bindings ~cache t = + (* XXX: If [t] is value, no need to [to_map]. Let's remove and inline + this into Tree.entries. *) + to_map ~cache t >|= function + | Error _ as e -> e + | Ok m -> Ok (StepMap.bindings m) + + let seq_of_updates updates value_bindings = + (* This operation can be costly for large updates. *) + if StepMap.is_empty updates then + (* Short-circuit return if we have no more updates to apply. *) + value_bindings + else + let value_bindings = + Seq.filter (fun (s, _) -> not (StepMap.mem s updates)) value_bindings + in + let updates = + StepMap.to_seq updates + |> Seq.filter_map (fun (s, elt) -> + match elt with Remove -> None | Add e -> Some (s, e)) + in + Seq.append value_bindings updates + + type ('v, 'acc, 'r) cps_folder = + path:Path.t -> 'acc -> int -> 'v -> ('acc, 'r) cont_lwt + (** A ('val, 'acc, 'r) cps_folder is a CPS, threaded fold function over + values of type ['v] producing an accumulator of type ['acc]. *) + + let fold : + type acc. + order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> + force:acc force -> + cache:bool -> + uniq:uniq -> + pre:(acc, step list) folder option -> + post:(acc, step list) folder option -> + path:Path.t -> + ?depth:depth -> + node:(acc, _) folder -> + contents:(acc, contents) folder -> + tree:(acc, _) folder -> + t -> + acc -> + acc Lwt.t = + fun ~order ~force ~cache ~uniq ~pre ~post ~path ?depth ~node ~contents + ~tree t acc -> + let env = t.info.env in + let marks = + match uniq with + | `False -> dummy_marks + | `True -> empty_marks () + | `Marks n -> n + in + let pre path bindings acc = + match pre with + | None -> Lwt.return acc + | Some pre -> + let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in + pre path s acc + in + let post path bindings acc = + match post with + | None -> Lwt.return acc + | Some post -> + let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in + post path s acc + in + let rec aux : type r. (t, acc, r) cps_folder = + fun ~path acc d t k -> + let apply acc = node path t acc >>= tree path (`Node t) in + let next acc = + match force with + | `True -> ( + match order with + | `Random state -> + let* m = to_map ~cache t >|= get_ok "fold" in + let arr = StepMap.to_array m in + let () = shuffle state arr in + let s = Array.to_seq arr in + (seq [@tailcall]) ~path acc d s k + | `Sorted -> + let* m = to_map ~cache t >|= get_ok "fold" in + (map [@tailcall]) ~path acc d (Some m) k + | `Undefined -> ( + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> (map [@tailcall]) ~path acc d (Some m) k + | Repo_value (repo, v) -> + (value [@tailcall]) ~path acc d (repo, v, None) k + | Repo_key (repo, _key) -> + let* v = to_value ~cache t >|= get_ok "fold" in + (value [@tailcall]) ~path acc d (repo, v, None) k + | Value_dirty (repo, v, um) -> + (value [@tailcall]) ~path acc d (repo, v, Some um) k + | Portable p -> (portable [@tailcall]) ~path acc d (p, None) k + | Portable_dirty (p, um) -> + (portable [@tailcall]) ~path acc d (p, Some um) k + | Pruned h -> pruned_hash_exn "fold" h)) + | `False skip -> ( + match cached_map t with + | Some n -> ( + match order with + | `Sorted | `Undefined -> + (map [@tailcall]) ~path acc d (Some n) k + | `Random state -> + let arr = StepMap.to_array n in + shuffle state arr; + let s = Array.to_seq arr in + (seq [@tailcall]) ~path acc d s k) + | None -> + (* XXX: That node is skipped if is is of tag Value *) + skip path acc >>= k) + in + match depth with + | None -> apply acc >>= next + | Some (`Eq depth) -> if d < depth then next acc else apply acc >>= k + | Some (`Le depth) -> + if d < depth then apply acc >>= next else apply acc >>= k + | Some (`Lt depth) -> + if d < depth - 1 then apply acc >>= next else apply acc >>= k + | Some (`Ge depth) -> if d < depth then next acc else apply acc >>= next + | Some (`Gt depth) -> + if d <= depth then next acc else apply acc >>= next + and aux_uniq : type r. (t, acc, r) cps_folder = + fun ~path acc d t k -> + if uniq = `False then (aux [@tailcall]) ~path acc d t k + else + let h = hash ~cache t in + match Hashes.add marks h with + | `Duplicate -> k acc + | `Ok -> (aux [@tailcall]) ~path acc d t k + and step : type r. (step * elt, acc, r) cps_folder = + fun ~path acc d (s, v) k -> + let path = Path.rcons path s in + match v with + | `Node n -> (aux_uniq [@tailcall]) ~path acc (d + 1) n k + | `Contents c -> ( + let apply () = + let tree path = tree path (`Contents c) in + Contents.fold ~force ~cache ~path contents tree (fst c) acc >>= k + in + match depth with + | None -> apply () + | Some (`Eq depth) -> if d = depth - 1 then apply () else k acc + | Some (`Le depth) -> if d < depth then apply () else k acc + | Some (`Lt depth) -> if d < depth - 1 then apply () else k acc + | Some (`Ge depth) -> if d >= depth - 1 then apply () else k acc + | Some (`Gt depth) -> if d >= depth then apply () else k acc) + and steps : type r. ((step * elt) Seq.t, acc, r) cps_folder = + fun ~path acc d s k -> + match s () with + | Seq.Nil -> k acc + | Seq.Cons (h, t) -> + (step [@tailcall]) ~path acc d h (fun acc -> + (steps [@tailcall]) ~path acc d t k) + and map : type r. (map option, acc, r) cps_folder = + fun ~path acc d m k -> + match m with + | None -> k acc + | Some m -> + let bindings = StepMap.to_seq m in + seq ~path acc d bindings k + and value : type r. (repo * value * updatemap option, acc, r) cps_folder = + fun ~path acc d (repo, v, updates) k -> + let bindings = Regular_value.seq ~env ~cache repo v in + let bindings = + match updates with + | None -> bindings + | Some updates -> seq_of_updates updates bindings + in + seq ~path acc d bindings k + and portable : type r. (portable * updatemap option, acc, r) cps_folder = + fun ~path acc d (v, updates) k -> + let bindings = Portable_value.seq ~env ~cache () v in + let bindings = + match updates with + | None -> bindings + | Some updates -> seq_of_updates updates bindings + in + seq ~path acc d bindings k + and seq : type r. ((step * elt) Seq.t, acc, r) cps_folder = + fun ~path acc d bindings k -> + let* acc = pre path bindings acc in + (steps [@tailcall]) ~path acc d bindings (fun acc -> + post path bindings acc >>= k) + in + aux_uniq ~path acc 0 t Lwt.return + + let incremental_length t step up n updates = + match t.info.length with + | None -> None + | Some len -> + Some + (lazy + (let len = Lazy.force len in + let exists = + match StepMap.find_opt step updates with + | Some (Add _) -> true + | Some Remove -> false + | None -> ( + match P.Node.Val.find n step with + | None -> false + | Some _ -> true) + in + match up with + | Add _ when not exists -> len + 1 + | Remove when exists -> len - 1 + | _ -> len)) + + let update t step up = + let env = t.info.env in + let of_map m = + let m' = + match up with + | Remove -> StepMap.remove step m + | Add v -> StepMap.add step v m + in + if m == m' then t else of_map ~env m' + in + let of_value repo n updates = + let updates' = StepMap.add step up updates in + if updates == updates' then t + else + let length = incremental_length t step up n updates in + of_value ?length ~env repo n ~updates:updates' + in + let of_portable n updates = + let updates' = StepMap.add step up updates in + if updates == updates' then t else of_portable_dirty ~env n updates' + in + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> Lwt.return (of_map m) + | Repo_value (repo, v) -> Lwt.return (of_value repo v StepMap.empty) + | Repo_key (repo, k) -> + let+ v = value_of_key ~cache:true t repo k >|= get_ok "update" in + of_value repo v StepMap.empty + | Value_dirty (repo, v, um) -> Lwt.return (of_value repo v um) + | Portable p -> Lwt.return (of_portable p StepMap.empty) + | Portable_dirty (p, um) -> Lwt.return (of_portable p um) + | Pruned h -> pruned_hash_exn "update" h + + let remove t step = update t step Remove + let add t step v = update t step (Add v) + + let compare (x : t) (y : t) = + if x == y then 0 + else compare_hash (hash ~cache:true x) (hash ~cache:true y) + + let t node = + let of_v v = of_v ~env:(Env.empty ()) v in + Type.map ~equal ~compare node of_v (fun t -> t.v) + + let _, t = + Type.mu2 (fun _ y -> + let elt = elt_t y in + let v = v_t elt in + let t = t v in + (v, t)) + + let elt_t = elt_t t + let dump = Type.pp_dump t + + let rec merge : type a. (t Merge.t -> a) -> a = + fun k -> + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + let+ m = to_map ~cache:true old >|= Option.of_result in + Ok (Some m)) + in + match merge_env x.info.env y.info.env with + | Error _ as e -> Lwt.return e + | Ok env -> ( + let* x = to_map ~cache:true x >|= Option.of_result in + let* y = to_map ~cache:true y >|= Option.of_result in + let m = + StepMap.merge elt_t (fun _step -> + (merge_elt [@tailcall]) Merge.option) + in + Merge.(f @@ option m) ~old x y >|= function + | Ok (Some map) -> Ok (of_map ~env map) + | Ok None -> Error (`Conflict "empty map") + | Error _ as e -> e) + in + k (Merge.v t f) + + and merge_elt : type r. (elt Merge.t, r) cont = + fun k -> + let open Merge.Infix in + let f : elt Merge.f = + fun ~old x y -> + match (x, y) with + | `Contents (x, cx), `Contents (y, cy) -> + let mold = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (_, m) -> ok (Some m) + | `Node _ -> ok None) + in + Merge.(f Metadata.merge) ~old:mold cx cy >>=* fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (c, _) -> ok (Some c) + | `Node _ -> ok None) + in + Merge.(f Contents.merge) ~old x y >>=* fun c -> + Merge.ok (`Contents (c, m)) + | `Node x, `Node y -> + (merge [@tailcall]) (fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents _ -> ok None + | `Node n -> ok (Some n)) + in + Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n)) + | _ -> Merge.conflict "add/add values" + in + k (Merge.seq [ Merge.default elt_t; Merge.v elt_t f ]) + + let merge_elt = merge_elt (fun x -> x) + end + + type node = Node.t [@@deriving irmin ~pp] + type node_key = Node.key [@@deriving irmin ~pp] + type contents_key = Contents.key [@@deriving irmin ~pp] + + type kinded_key = [ `Contents of Contents.key * metadata | `Node of Node.key ] + [@@deriving irmin] + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin ~equal] + + type t = [ `Node of node | `Contents of Contents.t * Metadata.t ] + [@@deriving irmin] + + let to_backend_node n = + Node.to_value ~cache:true n >|= get_ok "to_backend_node" + + let to_backend_portable_node n = + Node.to_portable_value ~cache:true n >|= get_ok "to_backend_portable_node" + + let of_backend_node repo n = + let env = Env.empty () in + let length = lazy (P.Node.Val.length n) in + Node.of_value ~length ~env repo n + + let dump ppf = function + | `Node n -> Fmt.pf ppf "node: %a" Node.dump n + | `Contents (c, _) -> Fmt.pf ppf "contents: %a" (Type.pp Contents.t) c + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 + || (c1 == c2 && m1 == m2) + || (Contents.equal c1 c2 && equal_metadata m1 m2) + + let equal (x : t) (y : t) = + x == y + || + match (x, y) with + | `Node x, `Node y -> Node.equal x y + | `Contents x, `Contents y -> contents_equal x y + | `Node _, `Contents _ | `Contents _, `Node _ -> false + + let is_empty = function + | `Node n -> Node.is_empty ~cache:true n + | `Contents _ -> false + + type elt = [ `Node of node | `Contents of contents * metadata ] + + let of_node n = `Node n + + let of_contents ?(metadata = Metadata.default) c = + let env = Env.empty () in + let c = Contents.of_value ~env c in + `Contents (c, metadata) + + let v : elt -> t = function + | `Contents (c, metadata) -> of_contents ~metadata c + | `Node n -> `Node n + + let pruned_with_env ~env = function + | `Contents (h, meta) -> `Contents (Contents.pruned ~env h, meta) + | `Node h -> `Node (Node.pruned ~env h) + + let pruned h = + let env = Env.empty () in + pruned_with_env ~env h + + let destruct x = x + + let clear ?(depth = 0) = function + | `Node n -> Node.clear ~max_depth:depth 0 n + | `Contents _ -> () + + let sub ~cache ctx t path = + let rec aux node path = + match Path.decons path with + | None -> Lwt.return_some node + | Some (h, p) -> ( + Node.findv ~cache ctx node h >>= function + | None | Some (`Contents _) -> Lwt.return_none + | Some (`Node n) -> (aux [@tailcall]) n p) + in + match t with + | `Node n -> (aux [@tailcall]) n path + | `Contents _ -> Lwt.return_none + + let find_tree (t : t) path = + let cache = true in + [%log.debug "Tree.find_tree %a" pp_path path]; + match (t, Path.rdecons path) with + | v, None -> Lwt.return_some v + | _, Some (path, file) -> ( + sub ~cache "find_tree.sub" t path >>= function + | None -> Lwt.return_none + | Some n -> Node.findv ~cache "find_tree.findv" n file) + + let id _ _ acc = Lwt.return acc + + let fold ?(order = `Sorted) ?(force = `True) ?(cache = false) ?(uniq = `False) + ?pre ?post ?depth ?(contents = id) ?(node = id) ?(tree = id) (t : t) acc = + match t with + | `Contents (c, _) as c' -> + let tree path = tree path c' in + Contents.fold ~force ~cache ~path:Path.empty contents tree c acc + | `Node n -> + Node.fold ~order ~force ~cache ~uniq ~pre ~post ~path:Path.empty ?depth + ~contents ~node ~tree n acc + + type stats = { + nodes : int; + leafs : int; + skips : int; + depth : int; + width : int; + } + [@@deriving irmin] + + let empty_stats = { nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } + let incr_nodes s = { s with nodes = s.nodes + 1 } + let incr_leafs s = { s with leafs = s.leafs + 1 } + let incr_skips s = { s with skips = s.skips + 1 } + + let set_depth p s = + let n_depth = List.length (Path.map p (fun _ -> ())) in + let depth = max n_depth s.depth in + { s with depth } + + let set_width childs s = + let width = max s.width (List.length childs) in + { s with width } + + let err_not_found n k = + Fmt.kstr invalid_arg "Irmin.Tree.%s: %a not found" n pp_path k + + let get_tree (t : t) path = + find_tree t path >|= function + | None -> err_not_found "get_tree" path + | Some v -> v + + let find_all t k = + find_tree t k >>= function + | None | Some (`Node _) -> Lwt.return_none + | Some (`Contents (c, m)) -> + let+ c = Contents.to_value ~cache:true c in + Some (get_ok "find_all" c, m) + + let find t k = + find_all t k >|= function None -> None | Some (c, _) -> Some c + + let get_all t k = + find_all t k >>= function + | None -> err_not_found "get" k + | Some v -> Lwt.return v + + let get t k = get_all t k >|= fun (c, _) -> c + let mem t k = find t k >|= function None -> false | _ -> true + let mem_tree t k = find_tree t k >|= function None -> false | _ -> true + + let kind t path = + let cache = true in + [%log.debug "Tree.kind %a" pp_path path]; + match (t, Path.rdecons path) with + | `Contents _, None -> Lwt.return_some `Contents + | `Node _, None -> Lwt.return_some `Node + | _, Some (dir, file) -> ( + sub ~cache "kind.sub" t dir >>= function + | None -> Lwt.return_none + | Some m -> ( + Node.findv ~cache "kind.findv" m file >>= function + | None -> Lwt.return_none + | Some (`Contents _) -> Lwt.return_some `Contents + | Some (`Node _) -> Lwt.return_some `Node)) + + let length t ?(cache = true) path = + [%log.debug "Tree.length %a" pp_path path]; + sub ~cache "length" t path >>= function + | None -> Lwt.return 0 + | Some n -> Node.length ~cache:true n + + let seq t ?offset ?length ?(cache = true) path = + [%log.debug "Tree.seq %a" pp_path path]; + sub ~cache "seq.sub" t path >>= function + | None -> Lwt.return Seq.empty + | Some n -> Node.seq ?offset ?length ~cache n >|= get_ok "seq" + + let list t ?offset ?length ?(cache = true) path = + seq t ?offset ?length ~cache path >|= List.of_seq + + let empty () = `Node (Node.empty ()) + + let singleton k ?(metadata = Metadata.default) c = + [%log.debug "Tree.singleton %a" pp_path k]; + let env = Env.empty () in + let base_tree = `Contents (Contents.of_value ~env c, metadata) in + Path.fold_right k + ~f:(fun step child -> `Node (Node.singleton ~env step child)) + ~init:base_tree + + (** During recursive updates, we keep track of whether or not we've made a + modification in order to avoid unnecessary allocations of identical tree + objects. *) + type 'a updated = Changed of 'a | Unchanged + + let maybe_equal (x : t) (y : t) = + if x == y then True + else + match (x, y) with + | `Node x, `Node y -> Node.maybe_equal x y + | _ -> if equal x y then True else False + + let get_env = function + | `Node n -> n.Node.info.env + | `Contents (c, _) -> c.Contents.info.env + + let update_tree ~cache ~f_might_return_empty_node ~f root_tree path = + (* User-introduced empty nodes will be removed immediately if necessary. *) + let prune_empty : node -> bool = + if not f_might_return_empty_node then Fun.const false + else Node.is_empty ~cache + in + match Path.rdecons path with + | None -> ( + let empty_tree = + match is_empty root_tree with + | true -> root_tree + | false -> `Node (Node.empty ()) + in + f (Some root_tree) >>= function + (* Here we consider "deleting" a root contents value or node to consist + of changing it to an empty node. Note that this introduces + sensitivity to ordering of subtree operations: updating in a subtree + and adding the subtree are not necessarily commutative. *) + | None -> Lwt.return empty_tree + | Some (`Node _ as new_root) -> ( + match maybe_equal root_tree new_root with + | True -> Lwt.return root_tree + | Maybe | False -> Lwt.return new_root) + | Some (`Contents c' as new_root) -> ( + match root_tree with + | `Contents c when contents_equal c c' -> Lwt.return root_tree + | _ -> Lwt.return new_root)) + | Some (path, file) -> ( + let rec aux : type r. path -> node -> (node updated, r) cont_lwt = + fun path parent_node k -> + let changed n = k (Changed n) in + match Path.decons path with + | None -> ( + let with_new_child t = Node.add parent_node file t >>= changed in + let* old_binding = + Node.findv ~cache "update_tree.findv" parent_node file + in + let* new_binding = f old_binding in + match (old_binding, new_binding) with + | None, None -> k Unchanged + | None, Some (`Contents _ as t) -> with_new_child t + | None, Some (`Node n as t) -> ( + match prune_empty n with + | true -> k Unchanged + | false -> with_new_child t) + | Some _, None -> Node.remove parent_node file >>= changed + | Some old_value, Some (`Node n as t) -> ( + match prune_empty n with + | true -> Node.remove parent_node file >>= changed + | false -> ( + match maybe_equal old_value t with + | True -> k Unchanged + | Maybe | False -> with_new_child t)) + | Some (`Contents c), Some (`Contents c' as t) -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Node _), Some (`Contents _ as t) -> with_new_child t) + | Some (step, key_suffix) -> + let* old_binding = + Node.findv ~cache "update_tree.findv" parent_node step + in + let to_recurse = + match old_binding with + | Some (`Node child) -> child + | None | Some (`Contents _) -> Node.empty () + in + (aux [@tailcall]) key_suffix to_recurse (function + | Unchanged -> + (* This includes [remove]s in an empty node, in which case we + want to avoid adding a binding anyway. *) + k Unchanged + | Changed child -> ( + match Node.is_empty ~cache child with + | true -> + (* A [remove] has emptied previously non-empty child with + binding [h], so we remove the binding. *) + Node.remove parent_node step >>= changed + | false -> + Node.add parent_node step (`Node child) >>= changed)) + in + let top_node = + match root_tree with `Node n -> n | `Contents _ -> Node.empty () + in + aux path top_node @@ function + | Unchanged -> Lwt.return root_tree + | Changed node -> + Env.copy ~into:node.info.env (get_env root_tree); + Lwt.return (`Node node)) + + let update t k ?(metadata = Metadata.default) f = + let cache = true in + [%log.debug "Tree.update %a" pp_path k]; + update_tree ~cache t k ~f_might_return_empty_node:false ~f:(fun t -> + let+ old_contents = + match t with + | Some (`Node _) | None -> Lwt.return_none + | Some (`Contents (c, _)) -> + let+ c = Contents.to_value ~cache c in + Some (get_ok "update" c) + in + match f old_contents with + | None -> None + | Some c -> of_contents ~metadata c |> Option.some) + + let add t k ?(metadata = Metadata.default) c = + [%log.debug "Tree.add %a" pp_path k]; + update_tree ~cache:true t k + ~f:(fun _ -> Lwt.return_some (of_contents ~metadata c)) + ~f_might_return_empty_node:false + + let add_tree t k v = + [%log.debug "Tree.add_tree %a" pp_path k]; + update_tree ~cache:true t k + ~f:(fun _ -> Lwt.return_some v) + ~f_might_return_empty_node:true + + let remove t k = + [%log.debug "Tree.remove %a" pp_path k]; + update_tree ~cache:true t k + ~f:(fun _ -> Lwt.return_none) + ~f_might_return_empty_node:false + + let update_tree t k f = + [%log.debug "Tree.update_tree %a" pp_path k]; + update_tree ~cache:true t k ~f:(Lwt.wrap1 f) ~f_might_return_empty_node:true + + let import repo = function + | `Contents (k, m) -> ( + cnt.contents_mem <- cnt.contents_mem + 1; + P.Contents.mem (P.Repo.contents_t repo) k >|= function + | true -> + let env = Env.empty () in + Some (`Contents (Contents.of_key ~env repo k, m)) + | false -> None) + | `Node k -> ( + cnt.node_mem <- cnt.node_mem + 1; + P.Node.mem (P.Repo.node_t repo) k >|= function + | true -> + let env = Env.empty () in + Some (`Node (Node.of_key ~env repo k)) + | false -> None) + + let import_with_env ~env repo = function + | `Node k -> `Node (Node.of_key ~env repo k) + | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) + + let import_no_check repo f = + let env = Env.empty () in + import_with_env ~env repo f + + let same_repo r1 r2 = + r1 == r2 || Conf.equal (P.Repo.config r1) (P.Repo.config r2) + + (* Given an arbitrary tree value, persist its contents to the given contents + and node stores via a depth-first {i post-order} traversal. We must export + a node's children before the node itself in order to get the {i keys} of + any un-persisted child values. *) + let export ?clear repo contents_t node_t n = + [%log.debug "Tree.export clear=%a" Fmt.(option bool) clear]; + let cache = + match clear with + | Some true | None -> + (* This choice of [cache] flag has no impact, since we either + immediately clear the corresponding cache or are certain that + the it is already filled. *) + false + | Some false -> true + in + + let add_node n v k = + cnt.node_add <- cnt.node_add + 1; + let* key = P.Node.add node_t v in + let () = + (* Sanity check: Did we just store the same hash as the one represented + by the Tree.Node [n]? *) + match Node.cached_hash n with + | None -> + (* No hash is in [n]. Computing it would result in getting it from + [v] or rebuilding a private node. *) + () + | Some h' -> + let h = P.Node.Key.to_hash key in + if not (equal_hash h h') then + backend_invariant_violation + "@[Tree.export: added inconsistent node binding@,\ + key: %a@,\ + value: %a@,\ + computed hash: %a@]" pp_node_key key Node.pp_value v pp_hash h' + in + k key + in + + let add_node_map n (x : Node.map) k = + let node = + (* Since we traverse in post-order, all children of [x] have already + been added. Thus, their keys are cached and we can retrieve them. *) + cnt.node_val_v <- cnt.node_val_v + 1; + StepMap.to_seq x + |> Seq.map (fun (step, v) -> + match v with + | `Node n -> ( + match Node.cached_key n with + | Some k -> (step, `Node k) + | None -> + assertion_failure + "Encountered child node value with uncached key \ + during export:@,\ + @ @[%a@]" dump v) + | `Contents (c, m) -> ( + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + assertion_failure + "Encountered child contents value with uncached key \ + during export:@,\ + @ @[%a@]" dump v)) + |> P.Node.Val.of_seq + in + add_node n node k + in + + let add_updated_node n (v : Node.value) (updates : Node.updatemap) k = + let node = + StepMap.fold + (fun k v acc -> + match v with + | Node.Remove -> P.Node.Val.remove acc k + | Node.Add (`Node n as v) -> ( + match Node.cached_key n with + | Some ptr -> P.Node.Val.add acc k (`Node ptr) + | None -> + assertion_failure + "Encountered child node value with uncached key during \ + export:@,\ + @ @[%a@]" dump v) + | Add (`Contents (c, m) as v) -> ( + match Contents.cached_key c with + | Some ptr -> P.Node.Val.add acc k (`Contents (ptr, m)) + | None -> + assertion_failure + "Encountered child contents value with uncached key \ + during export:@,\ + @ @[%a@]" dump v)) + updates v + in + add_node n node k + in + + let rec on_node : type r. [ `Node of node ] -> (node_key, r) cont_lwt = + fun (`Node n) k -> + let k key = + (* All the nodes in the exported tree should be cleaned using + [Node.export]. This ensures that [key] is stored in [n]. *) + Node.export ?clear repo n key; + k key + in + let has_repo = + match n.Node.v with + | Node.Key (repo', _) -> + if same_repo repo repo' then true + else + (* Case 1. [n] is a key from another repo. Let's crash. + + We could also only crash if the hash in the key is unknown to + [repo], or completely ignore the issue. *) + failwith "Can't export the node key from another repo" + | Value (repo', _, _) -> + if same_repo repo repo' then true + else + (* Case 2. [n] is a value from another repo. Let's crash. + + We could also ignore the issue. *) + failwith "Can't export a node value from another repo" + | Pruned _ | Portable_dirty _ | Map _ -> false + in + match n.Node.v with + | Pruned h -> + (* Case 3. [n] is a pruned hash. [P.Node.index node_t h] could be + different than [None], but let's always crash. *) + pruned_hash_exn "export" h + | Portable_dirty _ -> + (* Case 4. [n] is a portable value with diffs. The hash of the + reconstructed portable value could be known by [repo], but let's + always crash. *) + portable_value_exn "export" + | Map _ | Value _ | Key _ -> ( + match Node.cached_key n with + | Some key -> + if has_repo then + (* Case 5. [n] is a key that is accompanied by the [repo]. Let's + assume that [P.Node.mem node_t key] is [true] for performance + reason (not benched). *) + k key + else ( + cnt.node_mem <- cnt.node_mem + 1; + let* mem = P.Node.mem node_t key in + if not mem then + (* Case 6. [n] contains a key that is not known by [repo]. + Let's abort. *) + failwith "Can't export a key unkown from the repo" + else + (* Case 7. [n] contains a key that is known by the [repo]. *) + k key) + | None -> ( + let* skip_when_some = + match Node.cached_hash n with + | None -> + (* No pre-computed hash. *) + Lwt.return_none + | Some h -> ( + cnt.node_index <- cnt.node_index + 1; + P.Node.index node_t h >>= function + | None -> + (* Pre-computed hash is unknown by repo. + + NOTE: it's possible that this value already has a key + in the store, but it's not indexed. If so, we're + adding a duplicate here – this isn't an issue for + correctness, but does waste space. *) + Lwt.return_none + | Some key -> + cnt.node_mem <- cnt.node_mem + 1; + let+ mem = P.Node.mem node_t key in + if mem then + (* Case 8. The pre-computed hash is converted into + a key *) + Some key + else + (* The backend could produce a key from [h] but + doesn't know [h]. *) + None) + in + match skip_when_some with + | Some key -> k key + | None -> ( + (* Only [Map _ | Value _] possible now. + + Case 9. Let's export it to the backend. *) + let new_children_seq = + let seq = + match n.Node.v with + | Value (_, _, Some m) -> + StepMap.to_seq m + |> Seq.filter_map (function + | step, Node.Add v -> Some (step, v) + | _, Remove -> None) + | Map m -> StepMap.to_seq m + | Value (_, _, None) -> Seq.empty + | Key _ | Portable_dirty _ | Pruned _ -> + (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is + excluded above. *) + assert false + in + Seq.map (fun (_, x) -> x) seq + in + on_node_seq new_children_seq @@ fun `Node_children_exported -> + match (n.Node.v, Node.cached_value n) with + | Map x, _ -> add_node_map n x k + | Value (_, v, None), None | _, Some v -> add_node n v k + | Value (_, v, Some um), _ -> add_updated_node n v um k + | (Key _ | Portable_dirty _ | Pruned _), _ -> + (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is + excluded above. *) + assert false))) + and on_contents : + type r. + [ `Contents of Contents.t * metadata ] -> + ([ `Content_exported ], r) cont_lwt = + fun (`Contents (c, _)) k -> + match c.Contents.v with + | Contents.Key (_, key) -> + Contents.export ?clear repo c key; + k `Content_exported + | Contents.Value _ -> + let* v = Contents.to_value ~cache c in + let v = get_ok "export" v in + cnt.contents_add <- cnt.contents_add + 1; + let* key = P.Contents.add contents_t v in + let () = + let h = P.Contents.Key.to_hash key in + let h' = Contents.hash ~cache c in + if not (equal_hash h h') then + backend_invariant_violation + "@[Tree.export: added inconsistent contents binding@,\ + key: %a@,\ + value: %a@,\ + computed hash: %a@]" pp_contents_key key pp_contents v pp_hash + h' + in + Contents.export ?clear repo c key; + k `Content_exported + | Contents.Pruned h -> pruned_hash_exn "export" h + and on_node_seq : + type r. Node.elt Seq.t -> ([ `Node_children_exported ], r) cont_lwt = + fun seq k -> + match seq () with + | Seq.Nil -> + (* Have iterated on all children, let's export parent now *) + k `Node_children_exported + | Seq.Cons ((`Node _ as n), rest) -> + on_node n (fun _node_key -> on_node_seq rest k) + | Seq.Cons ((`Contents _ as c), rest) -> + on_contents c (fun `Content_exported -> on_node_seq rest k) + in + on_node (`Node n) (fun key -> Lwt.return key) + + let merge : t Merge.t = + let f ~old (x : t) y = + Merge.(f Node.merge_elt) ~old x y >>= function + | Ok t -> Merge.ok t + | Error e -> Lwt.return (Error e) + in + Merge.v t f + + let entries path tree = + let rec aux acc = function + | [] -> Lwt.return acc + | (path, h) :: todo -> + let* childs = Node.bindings ~cache:true h >|= get_ok "entries" in + let acc, todo = + List.fold_left + (fun (acc, todo) (k, v) -> + let path = Path.rcons path k in + match v with + | `Node v -> (acc, (path, v) :: todo) + | `Contents c -> ((path, c) :: acc, todo)) + (acc, todo) childs + in + (aux [@tailcall]) acc todo + in + (aux [@tailcall]) [] [ (path, tree) ] + + (** Given two forced lazy values, return an empty diff if they both use the + same dangling hash. *) + let diff_force_result (type a b) ~(empty : b) ~(diff_ok : a * a -> b) + (x : a or_error) (y : a or_error) : b = + match (x, y) with + | ( Error (`Dangling_hash h1 | `Pruned_hash h1), + Error (`Dangling_hash h2 | `Pruned_hash h2) ) -> ( + match equal_hash h1 h2 with true -> empty | false -> assert false) + | Error _, Ok _ -> assert false + | Ok _, Error _ -> assert false + | Ok x, Ok y -> diff_ok (x, y) + | Error _, Error _ -> assert false + + let diff_contents x y = + if Node.contents_equal x y then Lwt.return_nil + else + let* cx = Contents.to_value ~cache:true (fst x) in + let+ cy = Contents.to_value ~cache:true (fst y) in + diff_force_result cx cy ~empty:[] ~diff_ok:(fun (cx, cy) -> + [ `Updated ((cx, snd x), (cy, snd y)) ]) + + let diff_node (x : node) (y : node) = + let bindings n = + Node.to_map ~cache:true n >|= function + | Ok m -> Ok (StepMap.bindings m) + | Error _ as e -> e + in + let removed acc (k, (c, m)) = + let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in + (k, `Removed (c, m)) :: acc + in + let added acc (k, (c, m)) = + let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in + (k, `Added (c, m)) :: acc + in + let rec diff_bindings acc todo path x y = + let acc = ref acc in + let todo = ref todo in + let* () = + alist_iter2_lwt compare_step + (fun key v -> + let path = Path.rcons path key in + match v with + (* Left *) + | `Left (`Contents x) -> + let+ x = removed !acc (path, x) in + acc := x + | `Left (`Node x) -> + let* xs = entries path x in + let+ xs = Lwt_list.fold_left_s removed !acc xs in + acc := xs + (* Right *) + | `Right (`Contents y) -> + let+ y = added !acc (path, y) in + acc := y + | `Right (`Node y) -> + let* ys = entries path y in + let+ ys = Lwt_list.fold_left_s added !acc ys in + acc := ys + (* Both *) + | `Both (`Node x, `Node y) -> + todo := (path, x, y) :: !todo; + Lwt.return_unit + | `Both (`Contents x, `Node y) -> + let* ys = entries path y in + let* x = removed !acc (path, x) in + let+ ys = Lwt_list.fold_left_s added x ys in + acc := ys + | `Both (`Node x, `Contents y) -> + let* xs = entries path x in + let* y = added !acc (path, y) in + let+ ys = Lwt_list.fold_left_s removed y xs in + acc := ys + | `Both (`Contents x, `Contents y) -> + let+ content_diffs = + diff_contents x y >|= List.map (fun d -> (path, d)) + in + acc := content_diffs @ !acc) + x y + in + (diff_node [@tailcall]) !acc !todo + and diff_node acc = function + | [] -> Lwt.return acc + | (path, x, y) :: todo -> + if Node.equal x y then (diff_node [@tailcall]) acc todo + else + let* x = bindings x in + let* y = bindings y in + diff_force_result ~empty:Lwt.return_nil + ~diff_ok:(fun (x, y) -> diff_bindings acc todo path x y) + x y + in + (diff_node [@tailcall]) [] [ (Path.empty, x, y) ] + + let diff (x : t) (y : t) = + match (x, y) with + | `Contents ((c1, m1) as x), `Contents ((c2, m2) as y) -> + if contents_equal x y then Lwt.return_nil + else + let* c1 = Contents.to_value ~cache:true c1 >|= get_ok "diff" in + let* c2 = Contents.to_value ~cache:true c2 >|= get_ok "diff" in + Lwt.return [ (Path.empty, `Updated ((c1, m1), (c2, m2))) ] + | `Node x, `Node y -> diff_node x y + | `Contents (x, m), `Node y -> + let* diff = diff_node (Node.empty ()) y in + let+ x = Contents.to_value ~cache:true x >|= get_ok "diff" in + (Path.empty, `Removed (x, m)) :: diff + | `Node x, `Contents (y, m) -> + let* diff = diff_node x (Node.empty ()) in + let+ y = Contents.to_value ~cache:true y >|= get_ok "diff" in + (Path.empty, `Added (y, m)) :: diff + + type concrete = + [ `Tree of (Path.step * concrete) list + | `Contents of P.Contents.Val.t * Metadata.t ] + [@@deriving irmin] + + type 'a or_empty = Empty | Non_empty of 'a + + let of_concrete c = + let rec concrete : type r. concrete -> (t or_empty, r) cont = + fun t k -> + match t with + | `Contents (c, m) -> k (Non_empty (of_contents ~metadata:m c)) + | `Tree childs -> + tree StepMap.empty childs (function + | Empty -> k Empty + | Non_empty n -> k (Non_empty (`Node n))) + and tree : + type r. + Node.elt StepMap.t -> (step * concrete) list -> (node or_empty, r) cont + = + fun map t k -> + match t with + | [] -> + k + (if StepMap.is_empty map then Empty + else Non_empty (Node.of_map ~env:(Env.empty ()) map)) + | (s, n) :: t -> + (concrete [@tailcall]) n (fun v -> + (tree [@tailcall]) + (StepMap.update s + (function + | None -> ( + match v with + | Empty -> None (* Discard empty sub-directories *) + | Non_empty v -> Some v) + | Some _ -> + Fmt.invalid_arg + "of_concrete: duplicate bindings for step `%a`" + pp_step s) + map) + t k) + in + (concrete [@tailcall]) c (function Empty -> empty () | Non_empty x -> x) + + let to_concrete t = + let rec tree : type r. t -> (concrete, r) cont_lwt = + fun t k -> + match t with + | `Contents c -> contents c k + | `Node n -> + let* m = Node.to_map ~cache:true n in + let bindings = m |> get_ok "to_concrete" |> StepMap.bindings in + (node [@tailcall]) [] bindings (fun n -> + let n = List.sort (fun (s, _) (s', _) -> compare_step s s') n in + k (`Tree n)) + and contents : type r. Contents.t * metadata -> (concrete, r) cont_lwt = + fun (c, m) k -> + let* c = Contents.to_value ~cache:true c >|= get_ok "to_concrete" in + k (`Contents (c, m)) + and node : + type r. + (step * concrete) list -> + (step * Node.elt) list -> + ((step * concrete) list, r) cont_lwt = + fun childs x k -> + match x with + | [] -> k childs + | (s, n) :: t -> ( + match n with + | `Node _ as n -> + (tree [@tailcall]) n (fun tree -> node ((s, tree) :: childs) t k) + | `Contents c -> + (contents [@tailcall]) c (fun c -> + (node [@tailcall]) ((s, c) :: childs) t k)) + in + tree t (fun x -> Lwt.return x) + + let key (t : t) = + [%log.debug "Tree.key"]; + match t with + | `Node n -> ( + match Node.key n with Some key -> Some (`Node key) | None -> None) + | `Contents (c, m) -> ( + match Contents.key c with + | Some key -> Some (`Contents (key, m)) + | None -> None) + + let hash ?(cache = true) (t : t) = + [%log.debug "Tree.hash"]; + match t with + | `Node n -> `Node (Node.hash ~cache n) + | `Contents (c, m) -> `Contents (Contents.hash ~cache c, m) + + let stats ?(force = false) (t : t) = + let cache = true in + let force = + if force then `True + else `False (fun k s -> set_depth k s |> incr_skips |> Lwt.return) + in + let contents k _ s = set_depth k s |> incr_leafs |> Lwt.return in + let pre k childs s = + if childs = [] then Lwt.return s + else set_depth k s |> set_width childs |> incr_nodes |> Lwt.return + in + let post _ _ acc = Lwt.return acc in + fold ~force ~cache ~pre ~post ~contents t empty_stats + + let counters () = cnt + let dump_counters ppf () = dump_counters ppf cnt + let reset_counters () = reset_counters cnt + + let inspect = function + | `Contents _ -> `Contents + | `Node n -> + `Node + (match n.Node.v with + | Map _ -> `Map + | Value _ -> `Value + | Key _ -> `Key + | Portable_dirty _ -> `Portable_dirty + | Pruned _ -> `Pruned) + + module Proof = struct + type irmin_tree = t + + include Tree_proof + + type proof_tree = tree + type proof_inode = inode_tree + type node_proof = P.Node_portable.proof + + let proof_of_iproof : proof_inode -> proof_tree = function + | Blinded_inode h -> Blinded_node h + | Inode_values l -> Node l + | Inode_tree i -> Inode i + | Inode_extender ext -> Extender ext + + let rec proof_of_tree : type a. irmin_tree -> (proof_tree -> a) -> a = + fun tree k -> + match tree with + | `Contents (c, h) -> proof_of_contents c h k + | `Node node -> proof_of_node node k + + and proof_of_contents : + type a. Contents.t -> metadata -> (proof_tree -> a) -> a = + fun c m k -> + match Contents.cached_value c with + | Some v -> k (Contents (v, m)) + | None -> k (Blinded_contents (Contents.hash c, m)) + + and proof_of_node : type a. node -> (proof_tree -> a) -> a = + fun node k -> + (* Let's convert [node] to [node_proof]. + + As [node] might not be exported, we can only turn it into a portable + node. *) + let to_portable_value = + let value_of_key ~cache:_ _node _repo k = + let h = P.Node.Key.to_hash k in + err_dangling_hash h + in + Node.to_portable_value_aux ~cache:false ~value_of_key ~return:Fun.id + ~bind:(fun x f -> f x) + in + match to_portable_value node with + | Error (`Dangling_hash h) -> k (Blinded_node h) + | Error (`Pruned_hash h) -> k (Blinded_node h) + | Ok v -> + (* [to_proof] may trigger reads. This is fine. *) + let node_proof = P.Node_portable.to_proof v in + proof_of_node_proof node node_proof k + + (** [of_node_proof n np] is [p] (of type [Tree.Proof.t]) which is very + similar to [np] (of type [P.Node.Val.proof]) except that the values + loaded in [n] have been expanded. *) + and proof_of_node_proof : + type a. node -> node_proof -> (proof_tree -> a) -> a = + fun node p k -> + match p with + | `Blinded h -> k (Blinded_node h) + | `Inode (length, proofs) -> + iproof_of_inode node length proofs (fun p -> proof_of_iproof p |> k) + | `Values vs -> iproof_of_values node vs (fun p -> proof_of_iproof p |> k) + + and iproof_of_node_proof : + type a. node -> node_proof -> (proof_inode -> a) -> a = + fun node p k -> + match p with + | `Blinded h -> k (Blinded_inode h) + | `Inode (length, proofs) -> iproof_of_inode node length proofs k + | `Values vs -> iproof_of_values node vs k + + and iproof_of_inode : + type a. node -> int -> (_ * node_proof) list -> (proof_inode -> a) -> a + = + fun node length proofs k -> + let rec aux acc = function + | [] -> k (Inode_tree { length; proofs = List.rev acc }) + | (index, proof) :: rest -> + iproof_of_node_proof node proof (fun proof -> + aux ((index, proof) :: acc) rest) + in + (* We are dealing with an inode A. + Its children are Bs. + The children of Bs are Cs. + *) + match proofs with + | [ (index, proof) ] -> + (* A has 1 child. *) + iproof_of_node_proof node proof (function + | Inode_tree { length = length'; proofs = [ (i, p) ] } -> + (* B is an inode with 1 child, C isn't. *) + assert (length = length'); + k + (Inode_extender { length; segments = [ index; i ]; proof = p }) + | Inode_extender { length = length'; segments; proof } -> + (* B is an inode with 1 child, so is C. *) + assert (length = length'); + k + (Inode_extender + { length; segments = index :: segments; proof }) + | (Blinded_inode _ | Inode_values _ | Inode_tree _) as p -> + (* B is not an inode with 1 child. *) + k (Inode_tree { length; proofs = [ (index, p) ] })) + | _ -> aux [] proofs + + and iproof_of_values : + type a. + node -> (step * Node.pnode_value) list -> (proof_inode -> a) -> a = + let findv = + let value_of_key ~cache:_ _node _repo k = + let h = P.Node.Key.to_hash k in + err_dangling_hash h + in + Node.findv_aux ~value_of_key ~return:Fun.id ~bind:(fun x f -> f x) + in + fun node steps k -> + let rec aux acc = function + | [] -> k (Inode_values (List.rev acc)) + | (step, _) :: rest -> ( + match findv ~cache:false "Proof.iproof_of_values" node step with + | None -> assert false + | Some t -> + let k p = aux ((step, p) :: acc) rest in + proof_of_tree t k) + in + aux [] steps + + let of_tree t = proof_of_tree t Fun.id + + let rec load_proof : type a. env:_ -> proof_tree -> (kinded_hash -> a) -> a + = + fun ~env p k -> + match p with + | Blinded_node h -> k (`Node h) + | Node n -> load_node_proof ~env n k + | Inode { length; proofs } -> load_inode_proof ~env length proofs k + | Blinded_contents (h, m) -> k (`Contents (h, m)) + | Contents (v, m) -> + let h = P.Contents.Hash.hash v in + Env.add_contents_from_proof env h v; + k (`Contents (h, m)) + | Extender { length; segments; proof } -> + load_extender_proof ~env length segments proof k + + (* Recontruct private node from [P.Node.Val.proof] *) + and load_extender_proof : + type a. + env:_ -> int -> int list -> proof_inode -> (kinded_hash -> a) -> a = + fun ~env len segments p k -> + node_proof_of_proof ~env p (fun p -> + let np = proof_of_extender len segments p in + let v = P.Node_portable.of_proof ~depth:0 np in + let v = + match v with + | None -> Proof.bad_proof_exn "Invalid proof" + | Some v -> v + in + let h = P.Node_portable.hash_exn v in + Env.add_pnode_from_proof env h v; + k (`Node h)) + + and proof_of_extender len segments p : node_proof = + List.fold_left + (fun acc index -> `Inode (len, [ (index, acc) ])) + p (List.rev segments) + + (* Recontruct private node from [P.Node.Val.empty] *) + and load_node_proof : + type a. env:_ -> (step * proof_tree) list -> (kinded_hash -> a) -> a = + fun ~env n k -> + let rec aux acc = function + | [] -> + let h = P.Node_portable.hash_exn acc in + Env.add_pnode_from_proof env h acc; + k (`Node h) + | (s, p) :: rest -> + let k h = aux (P.Node_portable.add acc s h) rest in + load_proof ~env p k + in + aux (P.Node_portable.empty ()) n + + (* Recontruct private node from [P.Node.Val.proof] *) + and load_inode_proof : + type a. + env:_ -> int -> (_ * proof_inode) list -> (kinded_hash -> a) -> a = + fun ~env len proofs k -> + let rec aux : _ list -> _ list -> a = + fun acc proofs -> + match proofs with + | [] -> + let np = `Inode (len, List.rev acc) in + let v = P.Node_portable.of_proof ~depth:0 np in + let v = + match v with + | None -> Proof.bad_proof_exn "Invalid proof" + | Some v -> v + in + let h = P.Node_portable.hash_exn v in + Env.add_pnode_from_proof env h v; + k (`Node h) + | (i, p) :: rest -> + let k p = aux ((i, p) :: acc) rest in + node_proof_of_proof ~env p k + in + aux [] proofs + + and node_proof_of_proof : + type a. env:_ -> proof_inode -> (node_proof -> a) -> a = + fun ~env t k -> + match t with + | Blinded_inode x -> k (`Blinded x) + | Inode_tree { length; proofs } -> + node_proof_of_inode ~env length proofs k + | Inode_values n -> node_proof_of_node ~env n k + | Inode_extender { length; segments; proof } -> + node_proof_of_proof ~env proof (fun p -> + k (proof_of_extender length segments p)) + + and node_proof_of_inode : + type a. env:_ -> int -> (_ * proof_inode) list -> (node_proof -> a) -> a + = + fun ~env length proofs k -> + let rec aux acc = function + | [] -> k (`Inode (length, List.rev acc)) + | (i, p) :: rest -> + node_proof_of_proof ~env p (fun p -> aux ((i, p) :: acc) rest) + in + aux [] proofs + + and node_proof_of_node : + type a. env:_ -> (step * proof_tree) list -> (node_proof -> a) -> a = + fun ~env node k -> + let rec aux acc = function + | [] -> k (`Values (List.rev acc)) + | (s, p) :: rest -> + load_proof ~env p (fun n -> aux ((s, n) :: acc) rest) + in + aux [] node + + let to_tree p = + let env = Env.empty () in + Env.set_mode env Env.Deserialise; + let h = load_proof ~env (state p) Fun.id in + let tree = pruned_with_env ~env h in + Env.set_mode env Env.Consume; + tree + end + + let produce_proof repo kinded_key f = + Env.with_produce @@ fun env ~start_serialise -> + let tree = import_with_env ~env repo kinded_key in + let+ tree_after, result = f tree in + let after = hash tree_after in + (* Here, we build a proof from [tree] (not from [tree_after]!), on purpose: + we look at the effect on [f] on [tree]'s caches and we rely on the fact + that the caches are env across copy-on-write copies of [tree]. *) + clear tree; + start_serialise (); + let proof = Proof.of_tree tree in + (* [env] will be purged when leaving the scope, that should avoid any memory + leaks *) + let kinded_hash = Node.weaken_value kinded_key in + (Proof.v ~before:kinded_hash ~after proof, result) + + let verify_proof_exn p f = + Env.with_consume @@ fun env ~stop_deserialise -> + let before = Proof.before p in + let after = Proof.after p in + (* First convert to proof to [Env] *) + let h = Proof.(load_proof ~env (state p) Fun.id) in + (* Then check that the consistency of the proof *) + if not (equal_kinded_hash before h) then + Irmin_proof.bad_proof_exn "verify_proof: invalid before hash"; + let tree = pruned_with_env ~env h in + Lwt.catch + (fun () -> + stop_deserialise (); + (* Then apply [f] on a cleaned tree, an exception will be raised if [f] + reads out of the proof. *) + let+ tree_after, result = f tree in + (* then check that [after] corresponds to [tree_after]'s hash. *) + if not (equal_kinded_hash after (hash tree_after)) then + Irmin_proof.bad_proof_exn "verify_proof: invalid after hash"; + (tree_after, result)) + (function + | Pruned_hash h -> + (* finaly check that [f] only access valid parts of the proof. *) + Fmt.kstr Irmin_proof.bad_proof_exn + "verify_proof: %s is trying to read through a blinded node or \ + object (%a)" + h.context pp_hash h.hash + | e -> raise e) + + type verifier_error = [ `Proof_mismatch of string ] [@@deriving irmin] + + let verify_proof p f = + Lwt.catch + (fun () -> + let+ r = verify_proof_exn p f in + Ok r) + (function + | Irmin_proof.Bad_proof e -> + Lwt.return (Error (`Proof_mismatch e.context)) + | e -> Lwt.fail e) + + let hash_of_proof_state state = + let env = Env.empty () in + Proof.load_proof ~env state Fun.id + + module Private = struct + let get_env = get_env + + module Env = Env + end +end 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..844d07226e --- /dev/null +++ b/src/irmin-lwt/core/tree_intf.ml @@ -0,0 +1,494 @@ +(* + * 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 + +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 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 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 + + module Make (B : Backend.S) : sig + include + S + with type path = B.Node.Path.t + and type step = B.Node.Path.step + and type metadata = B.Node.Metadata.t + and type contents = B.Contents.value + and type contents_key = B.Contents.Key.t + and type hash = B.Hash.t + + type kinded_key = + [ `Contents of B.Contents.Key.t * metadata | `Node of B.Node.Key.t ] + [@@deriving irmin] + + val import : B.Repo.t -> kinded_key -> t option Lwt.t + val import_no_check : B.Repo.t -> kinded_key -> t + + val export : + ?clear:bool -> + B.Repo.t -> + [> write ] B.Contents.t -> + [> read_write ] B.Node.t -> + node -> + B.Node.key Lwt.t + + val dump : t Fmt.t + val equal : t -> t -> bool + val key : t -> kinded_key option + val hash : ?cache:bool -> t -> kinded_hash + val to_backend_node : node -> B.Node.Val.t Lwt.t + val to_backend_portable_node : node -> B.Node_portable.t Lwt.t + val of_backend_node : B.Repo.t -> B.Node.value -> node + + type 'result producer := + B.Repo.t -> + kinded_key -> + (t -> (t * 'result) Lwt.t) -> + (Proof.t * 'result) Lwt.t + + type verifier_error = [ `Proof_mismatch of string ] [@@deriving irmin] + + type 'result verifier := + Proof.t -> + (t -> (t * 'result) Lwt.t) -> + (t * 'result, verifier_error) result Lwt.t + + val produce_proof : 'a producer + val verify_proof : 'a verifier + val hash_of_proof_state : Proof.tree -> kinded_hash + end +end diff --git a/src/irmin-lwt/core/type.ml b/src/irmin-lwt/core/type.ml new file mode 100644 index 0000000000..dbf9c23465 --- /dev/null +++ b/src/irmin-lwt/core/type.ml @@ -0,0 +1,23 @@ +(* + * 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 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 From 9c9b14162838004f016fa0a0ac20e18373b30b4d Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:04:05 +0200 Subject: [PATCH 03/26] irmin-lwt: reformat imported sources with project ocamlformat (0.29.0) The Irmin 3 ([main]) sources imported in the previous commit were formatted under ocamlformat 0.26.2; the [eio] branch we are layering on top uses 0.29.0. [dune fmt] reformats the imported files to match the project's current style. No semantic change. --- src/irmin-lwt/core/branch_intf.ml | 3 +- src/irmin-lwt/core/commit.ml | 13 +- src/irmin-lwt/core/commit_intf.ml | 11 +- src/irmin-lwt/core/conf.ml | 8 +- src/irmin-lwt/core/contents_intf.ml | 3 +- src/irmin-lwt/core/merge.mli | 10 +- src/irmin-lwt/core/metrics.ml | 33 +++--- src/irmin-lwt/core/node.ml | 53 ++++----- src/irmin-lwt/core/node_intf.ml | 11 +- src/irmin-lwt/core/perms.ml | 7 +- src/irmin-lwt/core/proof.ml | 11 +- src/irmin-lwt/core/proof_intf.ml | 14 ++- src/irmin-lwt/core/storage_intf.ml | 6 +- src/irmin-lwt/core/store.ml | 8 +- src/irmin-lwt/core/store_intf.ml | 22 ++-- src/irmin-lwt/core/sync.ml | 3 +- src/irmin-lwt/core/tree.ml | 177 ++++++++++++++-------------- src/irmin-lwt/core/tree_intf.ml | 8 +- 18 files changed, 209 insertions(+), 192 deletions(-) diff --git a/src/irmin-lwt/core/branch_intf.ml b/src/irmin-lwt/core/branch_intf.ml index a34a4c28f8..bc84047cdf 100644 --- a/src/irmin-lwt/core/branch_intf.ml +++ b/src/irmin-lwt/core/branch_intf.ml @@ -58,5 +58,6 @@ module type Sigs = sig (** [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. *) + 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 index da05c48173..3805577e8a 100644 --- a/src/irmin-lwt/core/commit.ml +++ b/src/irmin-lwt/core/commit.ml @@ -133,11 +133,12 @@ module Store_generic_key (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) = + (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 @@ -584,7 +585,7 @@ module History (S : Store) = struct let merge = merge t ~info |> Merge.with_conflict (fun msg -> - Fmt.str "Recursive merging of common ancestors: %s" msg) + Fmt.str "Recursive merging of common ancestors: %s" msg) |> Merge.f in merge ~old c1 c2 diff --git a/src/irmin-lwt/core/commit_intf.ml b/src/irmin-lwt/core/commit_intf.ml index 7b0eddc57b..80aceed7e8 100644 --- a/src/irmin-lwt/core/commit_intf.ml +++ b/src/irmin-lwt/core/commit_intf.ml @@ -238,11 +238,12 @@ module type Sigs = sig (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) : + (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 diff --git a/src/irmin-lwt/core/conf.ml b/src/irmin-lwt/core/conf.ml index 0788380ce0..42e3688dde 100644 --- a/src/irmin-lwt/core/conf.ml +++ b/src/irmin-lwt/core/conf.ml @@ -149,10 +149,10 @@ let to_strings (_, conf) = conf |> M.to_seq |> Seq.map (fun (K k, v) -> - ( k.name, - match k.of_univ v with - | Some v -> Type.to_string k.ty v - | None -> assert false )) + ( k.name, + match k.of_univ v with + | Some v -> Type.to_string k.ty v + | None -> assert false )) let pp ppf t = t |> to_strings |> List.of_seq |> Fmt.Dump.(list (pair string string)) ppf diff --git a/src/irmin-lwt/core/contents_intf.ml b/src/irmin-lwt/core/contents_intf.ml index 64c0811f84..3c79b7df34 100644 --- a/src/irmin-lwt/core/contents_intf.ml +++ b/src/irmin-lwt/core/contents_intf.ml @@ -72,7 +72,8 @@ module type Sigs = sig 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. *) + (** [Json_value] allows any kind of json value to be stored, not only objects. + *) module V1 : sig module String : S with type t = string diff --git a/src/irmin-lwt/core/merge.mli b/src/irmin-lwt/core/merge.mli index 2ec7b19f34..8200af325a 100644 --- a/src/irmin-lwt/core/merge.mli +++ b/src/irmin-lwt/core/merge.mli @@ -41,7 +41,8 @@ val map : ('a -> 'c) -> ('a, 'b) result Lwt.t -> ('c, 'b) result Lwt.t 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. *) + 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]. *) @@ -82,7 +83,8 @@ val like : 'a Type.t -> 'b t -> ('a -> 'b) -> ('b -> 'a) -> 'a t 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]. *) +(** [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 @@ -174,8 +176,8 @@ end {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}. *) + of similar bindings themselves, by using the appropriate + {{!Merge.MSet} multi-sets}. *) (** Lift merge functions to sets. *) module Set (E : sig diff --git a/src/irmin-lwt/core/metrics.ml b/src/irmin-lwt/core/metrics.ml index eb3422c4c1..e531bdc580 100644 --- a/src/irmin-lwt/core/metrics.ml +++ b/src/irmin-lwt/core/metrics.ml @@ -1,18 +1,18 @@ (* -* Copyright (c) 2022 - Étienne Marais -* -* 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. -*) + * Copyright (c) 2022 - Étienne Marais + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) let uid = let id = ref (-1) in @@ -35,9 +35,8 @@ let set_state m v = m.state <- v type 'a update_mode = Mutate of ('a -> unit) | Replace of ('a -> 'a) -let v : - type a. ?origin:origin -> name:string -> initial_state:a -> a Repr.ty -> a t - = +let v : type a. + ?origin:origin -> name:string -> initial_state:a -> a Repr.ty -> a t = fun ?origin ~name ~initial_state repr -> { uid = uid (); origin; name; repr; state = initial_state } diff --git a/src/irmin-lwt/core/node.ml b/src/irmin-lwt/core/node.ml index a13a953688..8ade40e835 100644 --- a/src/irmin-lwt/core/node.ml +++ b/src/irmin-lwt/core/node.ml @@ -136,9 +136,9 @@ struct 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)) + `Contents (h, Metadata.default)) |~ case1 "contents-x" (pair contents_key_t Metadata.t) (fun (h, m) -> - `Contents (h, m)) + `Contents (h, m)) |> sealv let to_entry (k, (v : value)) = @@ -249,21 +249,19 @@ struct 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 }) + 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 @@ -439,10 +437,11 @@ 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) + (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 @@ -765,14 +764,14 @@ module V1 (N : Generic_key.S with type step = string) = struct | None, None, Some n -> `Node n | _ -> failwith "invalid node") |+ field "contents" (option Contents_key.t) (function - | `Contents (x, _) -> Some x - | _ -> None) + | `Contents (x, _) -> Some x + | _ -> None) |+ field "metadata" (option metadata_t) (function - | `Contents (_, x) when not (is_default x) -> Some x - | _ -> None) + | `Contents (_, x) when not (is_default x) -> Some x + | _ -> None) |+ field "node" (option Node_key.t) (function - | `Node n -> Some n - | _ -> None) + | `Node n -> Some n + | _ -> None) |> sealr let t : t Type.t = diff --git a/src/irmin-lwt/core/node_intf.ml b/src/irmin-lwt/core/node_intf.ml index 2fae339997..d59e3e3288 100644 --- a/src/irmin-lwt/core/node_intf.ml +++ b/src/irmin-lwt/core/node_intf.ml @@ -378,11 +378,12 @@ module type Sigs = sig (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) + (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 diff --git a/src/irmin-lwt/core/perms.ml b/src/irmin-lwt/core/perms.ml index 1d66477f05..8da4ae207a 100644 --- a/src/irmin-lwt/core/perms.ml +++ b/src/irmin-lwt/core/perms.ml @@ -37,8 +37,8 @@ operations – by upcasting: {[ - let read_only t = (t :> (_, read) Ref.t) - let write_only t = (t :> (_, write) Ref.t) + let read_only t = (t :> (_, read) Ref.t) + let write_only t = (t :> (_, write) Ref.t) ]} Note that the ['perms] phantom type parameter should be contravariant: it's @@ -63,4 +63,5 @@ type write = Write.t (** The type parameter of a handle with [write] permissions. *) type read_write = Read_write.t -(** The type parameter of a handle with both {!read} and {!write} permissions. *) +(** The type parameter of a handle with both {!read} and {!write} permissions. +*) diff --git a/src/irmin-lwt/core/proof.ml b/src/irmin-lwt/core/proof.ml index f1cdd1b1bf..a82dd20c10 100644 --- a/src/irmin-lwt/core/proof.ml +++ b/src/irmin-lwt/core/proof.ml @@ -78,11 +78,12 @@ 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) = + (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 diff --git a/src/irmin-lwt/core/proof_intf.ml b/src/irmin-lwt/core/proof_intf.ml index f32892a1d8..527b3966f4 100644 --- a/src/irmin-lwt/core/proof_intf.ml +++ b/src/irmin-lwt/core/proof_intf.ml @@ -60,7 +60,8 @@ module type S = sig {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. *) + sequence / decision proof corresponding to the path in that binary tree. + *) type 'a inode_extender = { length : int; segments : int list; proof : 'a } [@@deriving irmin] @@ -266,11 +267,12 @@ module type Proof = sig 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) : + (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 diff --git a/src/irmin-lwt/core/storage_intf.ml b/src/irmin-lwt/core/storage_intf.ml index 34486228e8..144622abc5 100644 --- a/src/irmin-lwt/core/storage_intf.ml +++ b/src/irmin-lwt/core/storage_intf.ml @@ -20,7 +20,8 @@ module type S = sig type value val v : Conf.t -> t Lwt.t - (** [v config] initialises a storage layer, with the configuration [config]. *) + (** [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]. *) @@ -58,5 +59,6 @@ module type Sigs = sig 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. *) + 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 index b73edf07bd..c3790b4832 100644 --- a/src/irmin-lwt/core/store.ml +++ b/src/irmin-lwt/core/store.ml @@ -129,7 +129,9 @@ module Make (B : Backend.S) = struct let write_error_t = let open Type in variant "write-error" (fun c m e -> function - | `Conflict x -> c x | `Too_many_retries x -> m x | `Test_was x -> e x) + | `Conflict x -> c x + | `Too_many_retries x -> m x + | `Test_was x -> e x) |~ case1 "conflict" string (fun x -> `Conflict x) |~ case1 "too-many-retries" int (fun x -> `Too_many_retries x) |~ case1 "test-got" (option tree_t) (fun x -> `Test_was x) @@ -1232,7 +1234,9 @@ module Make (B : Backend.S) = struct let t r = let open Type in variant "status" (fun empty branch commit -> function - | `Empty -> empty | `Branch b -> branch b | `Commit c -> commit c) + | `Empty -> empty + | `Branch b -> branch b + | `Commit c -> commit c) |~ case0 "empty" `Empty |~ case1 "branch" Branch.t (fun b -> `Branch b) |~ case1 "commit" (Commit.t r) (fun c -> `Commit c) diff --git a/src/irmin-lwt/core/store_intf.ml b/src/irmin-lwt/core/store_intf.ml index 09ba421064..b75118d3d9 100644 --- a/src/irmin-lwt/core/store_intf.ml +++ b/src/irmin-lwt/core/store_intf.ml @@ -26,12 +26,12 @@ module type S_generic_key = sig 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. *) + 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 @@ -273,7 +273,8 @@ module type S_generic_key = sig end val status : t -> Status.t - (** [status t] is [t]'s status. It can either be a branch, a commit or empty. *) + (** [status t] is [t]'s status. It can either be a branch, a commit or empty. + *) (** Managing the store's heads. *) module Head : sig @@ -365,7 +366,8 @@ module type S_generic_key = sig - [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}. *) + function's completion, mirroring the effect of invoking {!Tree.clear}. + *) val tree : commit -> tree (** [tree c] is [c]'s root tree. *) @@ -1015,8 +1017,8 @@ module type S_generic_key = sig module Branch : sig (** {1 Branch Store} - Manipulate relations between {{!branch} branches} and {{!commit} - commits}. *) + 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]. *) diff --git a/src/irmin-lwt/core/sync.ml b/src/irmin-lwt/core/sync.ml index 513c72b689..3aae1b58e5 100644 --- a/src/irmin-lwt/core/sync.ml +++ b/src/irmin-lwt/core/sync.ml @@ -92,7 +92,8 @@ module Make (S : Store.Generic_key.S) = struct let status_t t = let open Type in variant "status" (fun empty head -> function - | `Empty -> empty | `Head c -> head c) + | `Empty -> empty + | `Head c -> head c) |~ case0 "empty" `Empty |~ case1 "head" S.(commit_t @@ repo t) (fun c -> `Head c) |> sealv diff --git a/src/irmin-lwt/core/tree.ml b/src/irmin-lwt/core/tree.ml index 7090c53e93..f3dc36721d 100644 --- a/src/irmin-lwt/core/tree.ml +++ b/src/irmin-lwt/core/tree.ml @@ -459,7 +459,8 @@ module Make (P : Backend.S) = struct let update_t (elt : elt Type.t) : update Type.t = let open Type in variant "Node.update" (fun add remove -> function - | Add elt -> add elt | Remove -> remove) + | Add elt -> add elt + | Remove -> remove) |~ case1 "add" elt (fun elt -> Add elt) |~ case0 "remove" Remove |> sealv @@ -479,7 +480,7 @@ module Make (P : Backend.S) = struct |~ case1 "value" (pair P.Node.Val.t (option um)) (fun _ -> assert false) |~ case1 "pruned" hash_t (fun h -> Pruned h) |~ case1 "portable_dirty" (pair portable_t um) (fun (v, m) -> - Portable_dirty (v, m)) + Portable_dirty (v, m)) |> sealv let of_v ?length ~env v = @@ -561,10 +562,11 @@ module Make (P : Backend.S) = struct assert false module Core_value - (N : Node.Generic_key.Core - with type step := step - and type hash := hash - and type metadata := metadata) + (N : + Node.Generic_key.Core + with type step := step + and type hash := hash + and type metadata := metadata) (To_elt : sig type repo @@ -855,25 +857,25 @@ module Make (P : Backend.S) = struct | Node x -> a_of_hashable P.Node.Val.hash_exn x | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) - and hash_preimage_of_map : - type r. cache:bool -> t -> map -> (hash_preimage, r) cont = + and hash_preimage_of_map : type r. + cache:bool -> t -> map -> (hash_preimage, r) cont = fun ~cache t map k -> cnt.node_val_v <- cnt.node_val_v + 1; let bindings = StepMap.to_seq map in let must_build_portable_node = bindings |> Seq.exists (fun (_, v) -> - match v with - | `Node n -> Option.is_none (cached_key n) - | `Contents (c, _) -> Option.is_none (Contents.cached_key c)) + match v with + | `Node n -> Option.is_none (cached_key n) + | `Contents (c, _) -> Option.is_none (Contents.cached_key c)) in if must_build_portable_node then let pnode = bindings |> Seq.map (fun (step, v) -> - match v with - | `Contents (c, m) -> (step, `Contents (Contents.hash c, m)) - | `Node n -> hash ~cache n (fun k -> (step, `Node k))) + match v with + | `Contents (c, m) -> (step, `Contents (Contents.hash c, m)) + | `Node n -> hash ~cache n (fun k -> (step, `Node k))) |> Portable.of_seq in k (Pnode pnode) @@ -881,26 +883,26 @@ module Make (P : Backend.S) = struct let node = bindings |> Seq.map (fun (step, v) -> - match v with - | `Contents (c, m) -> ( - match Contents.cached_key c with - | Some k -> (step, `Contents (k, m)) - | None -> - (* We checked that all child keys are cached above *) - assert false) - | `Node n -> ( - match cached_key n with - | Some k -> (step, `Node k) - | None -> - (* We checked that all child keys are cached above *) - assert false)) + match v with + | `Contents (c, m) -> ( + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + (* We checked that all child keys are cached above *) + assert false) + | `Node n -> ( + match cached_key n with + | Some k -> (step, `Node k) + | None -> + (* We checked that all child keys are cached above *) + assert false)) |> P.Node.Val.of_seq in if cache then t.info.value <- Some node; k (Node node) - and hash_preimage_value_of_elt : - type r. cache:bool -> elt -> (hash_preimage_value, r) cont = + and hash_preimage_value_of_elt : type r. + cache:bool -> elt -> (hash_preimage_value, r) cont = fun ~cache e k -> match e with | `Contents (c, m) -> ( @@ -912,8 +914,7 @@ module Make (P : Backend.S) = struct | Some key -> k (Node_value (`Node key)) | None -> hash ~cache n (fun hash -> k (Pnode_value (`Node hash)))) - and hash_preimage_of_updates : - type r. + and hash_preimage_of_updates : type r. cache:bool -> t -> hash_preimage -> updatemap -> (hash_preimage, r) cont = fun ~cache t v updates k -> @@ -1295,7 +1296,7 @@ module Make (P : Backend.S) = struct let updates = StepMap.to_seq updates |> Seq.filter_map (fun (s, elt) -> - match elt with Remove -> None | Add e -> Some (s, e)) + match elt with Remove -> None | Add e -> Some (s, e)) in Seq.append value_bindings updates @@ -1304,8 +1305,7 @@ module Make (P : Backend.S) = struct (** A ('val, 'acc, 'r) cps_folder is a CPS, threaded fold function over values of type ['v] producing an accumulator of type ['acc]. *) - let fold : - type acc. + let fold : type acc. order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> force:acc force -> cache:bool -> @@ -2038,7 +2038,8 @@ module Make (P : Backend.S) = struct "@[Tree.export: added inconsistent node binding@,\ key: %a@,\ value: %a@,\ - computed hash: %a@]" pp_node_key key Node.pp_value v pp_hash h' + computed hash: %a@]" + pp_node_key key Node.pp_value v pp_hash h' in k key in @@ -2050,23 +2051,25 @@ module Make (P : Backend.S) = struct cnt.node_val_v <- cnt.node_val_v + 1; StepMap.to_seq x |> Seq.map (fun (step, v) -> - match v with - | `Node n -> ( - match Node.cached_key n with - | Some k -> (step, `Node k) - | None -> - assertion_failure - "Encountered child node value with uncached key \ - during export:@,\ - @ @[%a@]" dump v) - | `Contents (c, m) -> ( - match Contents.cached_key c with - | Some k -> (step, `Contents (k, m)) - | None -> - assertion_failure - "Encountered child contents value with uncached key \ - during export:@,\ - @ @[%a@]" dump v)) + match v with + | `Node n -> ( + match Node.cached_key n with + | Some k -> (step, `Node k) + | None -> + assertion_failure + "Encountered child node value with uncached key during \ + export:@,\ + @ @[%a@]" + dump v) + | `Contents (c, m) -> ( + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + assertion_failure + "Encountered child contents value with uncached key \ + during export:@,\ + @ @[%a@]" + dump v)) |> P.Node.Val.of_seq in add_node n node k @@ -2085,7 +2088,8 @@ module Make (P : Backend.S) = struct assertion_failure "Encountered child node value with uncached key during \ export:@,\ - @ @[%a@]" dump v) + @ @[%a@]" + dump v) | Add (`Contents (c, m) as v) -> ( match Contents.cached_key c with | Some ptr -> P.Node.Val.add acc k (`Contents (ptr, m)) @@ -2093,7 +2097,8 @@ module Make (P : Backend.S) = struct assertion_failure "Encountered child contents value with uncached key \ during export:@,\ - @ @[%a@]" dump v)) + @ @[%a@]" + dump v)) updates v in add_node n node k @@ -2195,8 +2200,8 @@ module Make (P : Backend.S) = struct | Value (_, _, Some m) -> StepMap.to_seq m |> Seq.filter_map (function - | step, Node.Add v -> Some (step, v) - | _, Remove -> None) + | step, Node.Add v -> Some (step, v) + | _, Remove -> None) | Map m -> StepMap.to_seq m | Value (_, _, None) -> Seq.empty | Key _ | Portable_dirty _ | Pruned _ -> @@ -2215,8 +2220,7 @@ module Make (P : Backend.S) = struct (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is excluded above. *) assert false))) - and on_contents : - type r. + and on_contents : type r. [ `Contents of Contents.t * metadata ] -> ([ `Content_exported ], r) cont_lwt = fun (`Contents (c, _)) k -> @@ -2237,14 +2241,14 @@ module Make (P : Backend.S) = struct "@[Tree.export: added inconsistent contents binding@,\ key: %a@,\ value: %a@,\ - computed hash: %a@]" pp_contents_key key pp_contents v pp_hash - h' + computed hash: %a@]" + pp_contents_key key pp_contents v pp_hash h' in Contents.export ?clear repo c key; k `Content_exported | Contents.Pruned h -> pruned_hash_exn "export" h - and on_node_seq : - type r. Node.elt Seq.t -> ([ `Node_children_exported ], r) cont_lwt = + and on_node_seq : type r. + Node.elt Seq.t -> ([ `Node_children_exported ], r) cont_lwt = fun seq k -> match seq () with | Seq.Nil -> @@ -2411,8 +2415,7 @@ module Make (P : Backend.S) = struct tree StepMap.empty childs (function | Empty -> k Empty | Non_empty n -> k (Non_empty (`Node n))) - and tree : - type r. + and tree : type r. Node.elt StepMap.t -> (step * concrete) list -> (node or_empty, r) cont = fun map t k -> @@ -2454,8 +2457,7 @@ module Make (P : Backend.S) = struct fun (c, m) k -> let* c = Contents.to_value ~cache:true c >|= get_ok "to_concrete" in k (`Contents (c, m)) - and node : - type r. + and node : type r. (step * concrete) list -> (step * Node.elt) list -> ((step * concrete) list, r) cont_lwt = @@ -2538,8 +2540,8 @@ module Make (P : Backend.S) = struct | `Contents (c, h) -> proof_of_contents c h k | `Node node -> proof_of_node node k - and proof_of_contents : - type a. Contents.t -> metadata -> (proof_tree -> a) -> a = + and proof_of_contents : type a. + Contents.t -> metadata -> (proof_tree -> a) -> a = fun c m k -> match Contents.cached_value c with | Some v -> k (Contents (v, m)) @@ -2570,8 +2572,8 @@ module Make (P : Backend.S) = struct (** [of_node_proof n np] is [p] (of type [Tree.Proof.t]) which is very similar to [np] (of type [P.Node.Val.proof]) except that the values loaded in [n] have been expanded. *) - and proof_of_node_proof : - type a. node -> node_proof -> (proof_tree -> a) -> a = + and proof_of_node_proof : type a. + node -> node_proof -> (proof_tree -> a) -> a = fun node p k -> match p with | `Blinded h -> k (Blinded_node h) @@ -2579,17 +2581,16 @@ module Make (P : Backend.S) = struct iproof_of_inode node length proofs (fun p -> proof_of_iproof p |> k) | `Values vs -> iproof_of_values node vs (fun p -> proof_of_iproof p |> k) - and iproof_of_node_proof : - type a. node -> node_proof -> (proof_inode -> a) -> a = + and iproof_of_node_proof : type a. + node -> node_proof -> (proof_inode -> a) -> a = fun node p k -> match p with | `Blinded h -> k (Blinded_inode h) | `Inode (length, proofs) -> iproof_of_inode node length proofs k | `Values vs -> iproof_of_values node vs k - and iproof_of_inode : - type a. node -> int -> (_ * node_proof) list -> (proof_inode -> a) -> a - = + and iproof_of_inode : type a. + node -> int -> (_ * node_proof) list -> (proof_inode -> a) -> a = fun node length proofs k -> let rec aux acc = function | [] -> k (Inode_tree { length; proofs = List.rev acc }) @@ -2621,8 +2622,7 @@ module Make (P : Backend.S) = struct k (Inode_tree { length; proofs = [ (index, p) ] })) | _ -> aux [] proofs - and iproof_of_values : - type a. + and iproof_of_values : type a. node -> (step * Node.pnode_value) list -> (proof_inode -> a) -> a = let findv = let value_of_key ~cache:_ _node _repo k = @@ -2661,8 +2661,7 @@ module Make (P : Backend.S) = struct load_extender_proof ~env length segments proof k (* Recontruct private node from [P.Node.Val.proof] *) - and load_extender_proof : - type a. + and load_extender_proof : type a. env:_ -> int -> int list -> proof_inode -> (kinded_hash -> a) -> a = fun ~env len segments p k -> node_proof_of_proof ~env p (fun p -> @@ -2683,8 +2682,8 @@ module Make (P : Backend.S) = struct p (List.rev segments) (* Recontruct private node from [P.Node.Val.empty] *) - and load_node_proof : - type a. env:_ -> (step * proof_tree) list -> (kinded_hash -> a) -> a = + and load_node_proof : type a. + env:_ -> (step * proof_tree) list -> (kinded_hash -> a) -> a = fun ~env n k -> let rec aux acc = function | [] -> @@ -2698,8 +2697,7 @@ module Make (P : Backend.S) = struct aux (P.Node_portable.empty ()) n (* Recontruct private node from [P.Node.Val.proof] *) - and load_inode_proof : - type a. + and load_inode_proof : type a. env:_ -> int -> (_ * proof_inode) list -> (kinded_hash -> a) -> a = fun ~env len proofs k -> let rec aux : _ list -> _ list -> a = @@ -2722,8 +2720,8 @@ module Make (P : Backend.S) = struct in aux [] proofs - and node_proof_of_proof : - type a. env:_ -> proof_inode -> (node_proof -> a) -> a = + and node_proof_of_proof : type a. + env:_ -> proof_inode -> (node_proof -> a) -> a = fun ~env t k -> match t with | Blinded_inode x -> k (`Blinded x) @@ -2734,9 +2732,8 @@ module Make (P : Backend.S) = struct node_proof_of_proof ~env proof (fun p -> k (proof_of_extender length segments p)) - and node_proof_of_inode : - type a. env:_ -> int -> (_ * proof_inode) list -> (node_proof -> a) -> a - = + and node_proof_of_inode : type a. + env:_ -> int -> (_ * proof_inode) list -> (node_proof -> a) -> a = fun ~env length proofs k -> let rec aux acc = function | [] -> k (`Inode (length, List.rev acc)) @@ -2745,8 +2742,8 @@ module Make (P : Backend.S) = struct in aux [] proofs - and node_proof_of_node : - type a. env:_ -> (step * proof_tree) list -> (node_proof -> a) -> a = + and node_proof_of_node : type a. + env:_ -> (step * proof_tree) list -> (node_proof -> a) -> a = fun ~env node k -> let rec aux acc = function | [] -> k (`Values (List.rev acc)) diff --git a/src/irmin-lwt/core/tree_intf.ml b/src/irmin-lwt/core/tree_intf.ml index 844d07226e..2b9ce0526f 100644 --- a/src/irmin-lwt/core/tree_intf.ml +++ b/src/irmin-lwt/core/tree_intf.ml @@ -164,7 +164,8 @@ module type S = sig (** [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]. *) + (** Same as {!find_all} but raise [Invalid_arg] if [k] is not present in [t]. + *) val list : t -> @@ -188,7 +189,8 @@ module type S = sig ?cache:bool -> path -> (step * t) Seq.t Lwt.t - (** [seq t key] follows the same behavior as {!list} but returns a sequence. *) + (** [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. *) @@ -309,7 +311,7 @@ module type S = sig See {{:https://github.com/mirage/irmin/blob/main/examples/fold.ml} - examples/fold.ml} for a demo of the different {!folder}s. + examples/fold.ml} for a demo of the different {!folder}s. See {!force} for details about the [force] parameters. By default it is [`True]. From ef95a5033fe741ceda63cee422051dc6958d6f5c Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:04:24 +0200 Subject: [PATCH 04/26] irmin-lwt: strip Store.Make and Tree.Make implementations [Store.Make (B : Backend.S)] (~1300 lines, [main:src/irmin/store.ml]) and [Tree.Make (B : Backend.S)] (~2800 lines, [main:src/irmin/tree.ml]) are removed from the shim. They are not needed: a later commit adds [Wrap_store.Make], which wraps the already-built Eio [Generic_key.S] from [Inner] back into a Lwt-typed surface, delegating tree machinery to [Inner.Tree]. The two functor declarations are also removed from [Store_intf.Sigs] and [Tree_intf.Sigs]; only the module types stay. [Json_tree] and the [type Remote.t += Store of ...] constructor are preserved in [store.ml] (they operate on any [Store.S]). The rest of the file is reduced to [include Store_intf]. --- src/irmin-lwt/core/store.ml | 1238 +------------ src/irmin-lwt/core/store_intf.ml | 10 - src/irmin-lwt/core/tree.ml | 2821 +----------------------------- src/irmin-lwt/core/tree_intf.ml | 78 +- 4 files changed, 46 insertions(+), 4101 deletions(-) diff --git a/src/irmin-lwt/core/store.ml b/src/irmin-lwt/core/store.ml index c3790b4832..65707565e9 100644 --- a/src/irmin-lwt/core/store.ml +++ b/src/irmin-lwt/core/store.ml @@ -14,13 +14,19 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open! Import -include Store_intf -open Merge.Infix +(** Store module types + [Json_tree] helper. -let src = Logs.Src.create "irmin" ~doc:"Irmin branch-consistent store" + 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. *) -module Log = (val Logs.src_log src : Logs.LOG) +open! Import +include Store_intf module Generic_key = struct module type S = S_generic_key @@ -29,1228 +35,6 @@ module Generic_key = struct module type KV_maker = KV_maker_generic_key end -module Make (B : Backend.S) = struct - module Schema = B.Schema - module Contents_key = B.Contents.Key - module Node_key = B.Node.Key - module Commit_key = B.Commit.Key - module Metadata = B.Node.Metadata - module Typed = Hash.Typed (B.Hash) - module Hash = B.Hash - module Branch_store = B.Branch - module Path = B.Node.Path - module Commits = Commit.History (B.Commit) - module Backend = B - module T = Tree.Make (B) - - module Info = struct - include B.Commit.Info - - let pp = Type.pp t - end - - module Contents = struct - include B.Contents.Val - module H = Typed (B.Contents.Val) - - let of_key r k = B.Contents.find (B.Repo.contents_t r) k - - let of_hash r h = - let store = B.Repo.contents_t r in - B.Contents.index store h >>= function - | None -> Lwt.return_none - | Some k -> B.Contents.find store k - - let hash c = H.hash c - end - - module Tree = struct - include T - - let find_key r t = - match key t with - | Some k -> Lwt.return (Some k) - | None -> ( - match hash t with - | `Node h -> ( - B.Node.index (B.Repo.node_t r) h >|= function - | None -> None - | Some k -> Some (`Node k)) - | `Contents (h, m) -> ( - B.Contents.index (B.Repo.contents_t r) h >|= function - | None -> None - | Some k -> Some (`Contents (k, m)))) - - let of_key r k = import r k - - let of_hash r = function - | `Node h -> ( - B.Node.index (B.Repo.node_t r) h >>= function - | None -> Lwt.return_none - | Some k -> of_key r (`Node k)) - | `Contents (h, m) -> ( - B.Contents.index (B.Repo.contents_t r) h >>= function - | None -> Lwt.return_none - | Some k -> of_key r (`Contents (k, m))) - - let shallow r h = import_no_check r h - let kinded_hash = hash - - let hash : ?cache:bool -> t -> hash = - fun ?cache tr -> - match hash ?cache tr with `Node h -> h | `Contents (h, _) -> h - - let pp = Type.pp t - end - - type branch = Branch_store.Key.t [@@deriving irmin ~equal ~pp] - type contents_key = B.Contents.Key.t [@@deriving irmin ~pp ~equal] - type node_key = B.Node.Key.t [@@deriving irmin ~pp ~equal] - type commit_key = B.Commit.Key.t [@@deriving irmin ~pp ~equal] - type repo = B.Repo.t - type commit = { r : repo; key : commit_key; v : B.Commit.value } - type hash = Hash.t [@@deriving irmin ~equal ~pp ~compare] - type node = Tree.node [@@deriving irmin] - type contents = Contents.t [@@deriving irmin ~equal] - type metadata = Metadata.t [@@deriving irmin] - type tree = Tree.t [@@deriving irmin ~pp] - type path = Path.t [@@deriving irmin ~pp] - type step = Path.step [@@deriving irmin] - type info = Info.t [@@deriving irmin] - type Remote.t += E of B.Remote.endpoint - type lca_error = [ `Max_depth_reached | `Too_many_lcas ] [@@deriving irmin] - type ff_error = [ `Rejected | `No_change | lca_error ] - - type write_error = - [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] - - (* The deriver does not work here because of it cannot derive the - [Merge.conflict] inheritance. *) - let write_error_t = - let open Type in - variant "write-error" (fun c m e -> function - | `Conflict x -> c x - | `Too_many_retries x -> m x - | `Test_was x -> e x) - |~ case1 "conflict" string (fun x -> `Conflict x) - |~ case1 "too-many-retries" int (fun x -> `Too_many_retries x) - |~ case1 "test-got" (option tree_t) (fun x -> `Test_was x) - |> sealv - - (* The deriver does not work here because of it cannot derive the - [lca_error] inheritance. *) - let ff_error_t = - Type.enum "ff-error" - [ - ("max-depth-reached", `Max_depth_reached); - ("too-many-lcas", `Too_many_lcas); - ("no-change", `No_change); - ("rejected", `Rejected); - ] - - let pp_int = Type.pp Type.int - let save_contents b c = B.Contents.add b c - - let save_tree ?(clear = true) r x y (tr : Tree.t) = - match Tree.destruct tr with - | `Contents (c, _) -> - let* c = Tree.Contents.force_exn c in - let+ k = save_contents x c in - `Contents k - | `Node n -> - let+ k = Tree.export ~clear r x y n in - `Node k - - module Contents_keys = Set.Make (struct - type t = Contents_key.t [@@deriving irmin ~compare] - end) - - module Commit = struct - type t = commit - - let t r = - let open Type in - record "commit" (fun key v -> { r; key; v }) - |+ field "key" B.Commit.Key.t (fun t -> t.key) - |+ field "value" B.Commit.Val.t (fun t -> t.v) - |> sealr - - let v ?(clear = true) r ~info ~parents tree = - B.Repo.batch r @@ fun contents_t node_t commit_t -> - let* node = - match Tree.destruct tree with - | `Node t -> Tree.export ~clear r contents_t node_t t - | `Contents _ -> Lwt.fail_invalid_arg "cannot add contents at the root" - in - let v = B.Commit.Val.v ~info ~node ~parents in - let+ key = B.Commit.add commit_t v in - { r; key; v } - - let node t = B.Commit.Val.node t.v - let tree t = Tree.import_no_check t.r (`Node (node t)) - let equal x y = equal_commit_key x.key y.key - let key t = t.key - let hash t = B.Commit.Key.to_hash t.key - let info t = B.Commit.Val.info t.v - let parents t = B.Commit.Val.parents t.v - let pp_hash ppf t = Type.pp Hash.t ppf (hash t) - let pp_key ppf t = Type.pp B.Commit.Key.t ppf t.key - let pp ppf commit = Type.pp (t commit.r) ppf commit - - let of_key r key = - B.Commit.find (B.Repo.commit_t r) key >|= function - | None -> None - | Some v -> Some { r; key; v } - - let of_hash r hash = - B.Commit.index (B.Repo.commit_t r) hash >>= function - | None -> Lwt.return_none - | Some key -> of_key r key - - module H = Typed (B.Commit.Val) - - let to_backend_commit t = t.v - let of_backend_commit r key v = { r; key; v } - - let equal_opt x y = - match (x, y) with - | None, None -> true - | Some x, Some y -> equal x y - | _ -> false - end - - let to_backend_portable_node = Tree.to_backend_portable_node - let to_backend_node = Tree.to_backend_node - let of_backend_node = Tree.of_backend_node - let to_backend_commit = Commit.to_backend_commit - let of_backend_commit = Commit.of_backend_commit - - type head_ref = [ `Branch of branch | `Head of commit option ref ] - - module OCamlGraph = Graph - module Graph = Node.Graph (B.Node) - - module KGraph = - Object_graph.Make (B.Contents.Key) (B.Node.Key) (B.Commit.Key) - (Branch_store.Key) - - type slice = B.Slice.t [@@deriving irmin] - type watch = unit -> unit Lwt.t - - let unwatch w = w () - - module Repo = struct - type t = repo - - let v = B.Repo.v - let config = B.Repo.config - let close = B.Repo.close - let branch_t t = B.Repo.branch_t t - let commit_t t = B.Repo.commit_t t - let node_t t = B.Repo.node_t t - let contents_t t = B.Repo.contents_t t - let branches t = B.Branch.list (branch_t t) - - let heads repo = - let t = branch_t repo in - let* bs = Branch_store.list t in - Lwt_list.fold_left_s - (fun acc r -> - Branch_store.find t r >>= function - | None -> Lwt.return acc - | Some k -> ( - Commit.of_key repo k >|= function - | None -> acc - | Some h -> h :: acc)) - [] bs - - let export ?(full = true) ?depth ?(min = []) ?(max = `Head) t = - [%log.debug - "export depth=%s full=%b min=%d max=%s" - (match depth with None -> "" | Some d -> string_of_int d) - full (List.length min) - (match max with - | `Head -> "heads" - | `Max m -> string_of_int (List.length m))]; - let* max = match max with `Head -> heads t | `Max m -> Lwt.return m in - let* slice = B.Slice.empty () in - let max = List.map (fun x -> `Commit x.key) max in - let min = List.map (fun x -> `Commit x.key) min in - let pred = function - | `Commit k -> - let+ parents = Commits.parents (commit_t t) k in - List.map (fun x -> `Commit x) parents - | _ -> Lwt.return_nil - in - let* g = KGraph.closure ?depth ~pred ~min ~max () in - let keys = - List.fold_left - (fun acc -> function `Commit c -> c :: acc | _ -> acc) - [] (KGraph.vertex g) - in - let root_nodes = ref [] in - let* () = - Lwt_list.iter_p - (fun k -> - B.Commit.find (commit_t t) k >>= function - | None -> Lwt.return_unit - | Some c -> - root_nodes := B.Commit.Val.node c :: !root_nodes; - B.Slice.add slice (`Commit (Commit_key.to_hash k, c))) - keys - in - if not full then Lwt.return slice - else - (* XXX: we can compute a [min] if needed *) - let* nodes = Graph.closure (node_t t) ~min:[] ~max:!root_nodes in - let contents = ref Contents_keys.empty in - let* () = - Lwt_list.iter_p - (fun k -> - B.Node.find (node_t t) k >>= function - | None -> Lwt.return_unit - | Some v -> - List.iter - (function - | _, `Contents (c, _) -> - contents := Contents_keys.add c !contents - | _ -> ()) - (B.Node.Val.list v); - B.Slice.add slice (`Node (Node_key.to_hash k, v))) - nodes - in - let+ () = - Lwt_list.iter_p - (fun k -> - B.Contents.find (contents_t t) k >>= function - | None -> Lwt.return_unit - | Some m -> - B.Slice.add slice (`Contents (Contents_key.to_hash k, m))) - (Contents_keys.elements !contents) - in - slice - - exception Import_error of string - - let import_error fmt = Fmt.kstr (fun x -> Lwt.fail (Import_error x)) fmt - - let import t s = - let aux name key_to_hash add (h, v) = - let* k' = add v in - let h' = key_to_hash k' in - if not (equal_hash h h') then - import_error "%s import error: expected %a, got %a" name pp_hash h - pp_hash h' - else Lwt.return_unit - in - let contents = ref [] in - let nodes = ref [] in - let commits = ref [] in - let* () = - B.Slice.iter s (function - | `Contents c -> - contents := c :: !contents; - Lwt.return_unit - | `Node n -> - nodes := n :: !nodes; - Lwt.return_unit - | `Commit c -> - commits := c :: !commits; - Lwt.return_unit) - in - B.Repo.batch t @@ fun contents_t node_t commit_t -> - Lwt.catch - (fun () -> - let* () = - Lwt_list.iter_p - (aux "Contents" B.Contents.Key.to_hash - (B.Contents.add contents_t)) - !contents - in - Lwt_list.iter_p - (aux "Node" B.Node.Key.to_hash (B.Node.add node_t)) - !nodes - >>= fun () -> - let+ () = - Lwt_list.iter_p - (aux "Commit" B.Commit.Key.to_hash (B.Commit.add commit_t)) - !commits - in - Ok ()) - (function - | Import_error e -> Lwt.return (Error (`Msg e)) - | e -> Fmt.kstr Lwt.fail_invalid_arg "impot error: %a" Fmt.exn e) - - type elt = - [ `Commit of commit_key - | `Node of node_key - | `Contents of contents_key - | `Branch of B.Branch.Key.t ] - [@@deriving irmin] - - let ignore_lwt _ = Lwt.return_unit - let return_false _ = Lwt.return false - let default_pred_contents _ _ = Lwt.return [] - - let default_pred_node t k = - B.Node.find (node_t t) k >|= function - | None -> [] - | Some v -> - List.rev_map - (function - | _, `Node n -> `Node n | _, `Contents (c, _) -> `Contents c) - (B.Node.Val.list v) - - let default_pred_commit t c = - B.Commit.find (commit_t t) c >|= function - | None -> - [%log.debug "%a: not found" pp_commit_key c]; - [] - | Some c -> - let node = B.Commit.Val.node c in - let parents = B.Commit.Val.parents c in - [ `Node node ] @ List.map (fun k -> `Commit k) parents - - let default_pred_branch t b = - B.Branch.find (branch_t t) b >|= function - | None -> - [%log.debug "%a: not found" pp_branch b]; - [] - | Some b -> [ `Commit b ] - - let iter ?cache_size ~min ~max ?edge ?(branch = ignore_lwt) - ?(commit = ignore_lwt) ?(node = ignore_lwt) ?(contents = ignore_lwt) - ?(skip_branch = return_false) ?(skip_commit = return_false) - ?(skip_node = return_false) ?(skip_contents = return_false) - ?(pred_branch = default_pred_branch) - ?(pred_commit = default_pred_commit) ?(pred_node = default_pred_node) - ?(pred_contents = default_pred_contents) ?(rev = true) t = - let node = function - | `Commit x -> commit x - | `Node x -> node x - | `Contents x -> contents x - | `Branch x -> branch x - in - let skip = function - | `Commit x -> skip_commit x - | `Node x -> skip_node x - | `Contents x -> skip_contents x - | `Branch x -> skip_branch x - in - let pred = function - | `Commit x -> pred_commit t x - | `Node x -> pred_node t x - | `Contents x -> pred_contents t x - | `Branch x -> pred_branch t x - in - KGraph.iter ?cache_size ~pred ~min ~max ~node ?edge ~skip ~rev () - - let breadth_first_traversal ?cache_size ~max ?(branch = ignore_lwt) - ?(commit = ignore_lwt) ?(node = ignore_lwt) ?(contents = ignore_lwt) - ?(pred_branch = default_pred_branch) - ?(pred_commit = default_pred_commit) ?(pred_node = default_pred_node) - ?(pred_contents = default_pred_contents) t = - let node = function - | `Commit x -> commit x - | `Node x -> node x - | `Contents x -> contents x - | `Branch x -> branch x - in - let pred = function - | `Commit x -> pred_commit t x - | `Node x -> pred_node t x - | `Contents x -> pred_contents t x - | `Branch x -> pred_branch t x - in - KGraph.breadth_first_traversal ?cache_size ~pred ~max ~node () - end - - type t = { - repo : Repo.t; - head_ref : head_ref; - mutable tree : (commit * tree) option; - (* cache for the store tree *) - lock : Lwt_mutex.t; - } - - let repo t = t.repo - let branch_store t = Repo.branch_t t.repo - let commit_store t = Repo.commit_t t.repo - - let status t = - match t.head_ref with - | `Branch b -> `Branch b - | `Head h -> ( match !h with None -> `Empty | Some c -> `Commit c) - - let head_ref t = - match t.head_ref with - | `Branch t -> `Branch t - | `Head h -> ( match !h with None -> `Empty | Some h -> `Head h) - - let branch t = - match head_ref t with - | `Branch t -> Lwt.return_some t - | `Empty | `Head _ -> Lwt.return_none - - let err_no_head s = Fmt.kstr Lwt.fail_invalid_arg "Irmin.%s: no head" s - - let retry_merge name fn = - let rec aux i = - fn () >>= function - | Error _ as c -> Lwt.return c - | Ok true -> Merge.ok () - | Ok false -> - [%log.debug "Irmin.%s: conflict, retrying (%d)." name i]; - aux (i + 1) - in - aux 1 - - let of_ref repo head_ref = - let lock = Lwt_mutex.create () in - Lwt.return { lock; head_ref; repo; tree = None } - - let err_invalid_branch t = - let err = Fmt.str "%a is not a valid branch name." pp_branch t in - Lwt.fail (Invalid_argument err) - - let of_branch repo key = - if Branch_store.Key.is_valid key then of_ref repo (`Branch key) - else err_invalid_branch key - - let main repo = of_branch repo Branch_store.Key.main - let master = main - let empty repo = of_ref repo (`Head (ref None)) - let of_commit c = of_ref c.r (`Head (ref (Some c))) - - let skip_key key = - [%log.debug "[watch-key] key %a has not changed" pp_path key]; - Lwt.return_unit - - let changed_key key old_t new_t = - [%log.debug - fun l -> - let pp = Fmt.option ~none:(Fmt.any "") pp_hash in - let old_h = Option.map Tree.hash old_t in - let new_h = Option.map Tree.hash new_t in - l "[watch-key] key %a has changed: %a -> %a" pp_path key pp old_h pp - new_h] - - let with_tree ~key x f = - x >>= function - | None -> skip_key key - | Some x -> - changed_key key None None; - f x - - let lift_tree_diff ~key tree fn = function - | `Removed x -> - with_tree ~key (tree x) @@ fun v -> - changed_key key (Some v) None; - fn @@ `Removed (x, v) - | `Added x -> - with_tree ~key (tree x) @@ fun v -> - changed_key key None (Some v); - fn @@ `Added (x, v) - | `Updated (x, y) -> ( - assert (not (Commit.equal x y)); - let* vx = tree x in - let* vy = tree y in - match (vx, vy) with - | None, None -> skip_key key - | None, Some vy -> - changed_key key None (Some vy); - fn @@ `Added (y, vy) - | Some vx, None -> - changed_key key (Some vx) None; - fn @@ `Removed (x, vx) - | Some vx, Some vy -> - if Tree.equal vx vy then skip_key key - else ( - changed_key key (Some vx) (Some vy); - fn @@ `Updated ((x, vx), (y, vy)))) - - let head t = - let h = - match head_ref t with - | `Head key -> Lwt.return_some key - | `Empty -> Lwt.return_none - | `Branch name -> ( - Branch_store.find (branch_store t) name >>= function - | None -> Lwt.return_none - | Some k -> Commit.of_key t.repo k) - in - let+ h = h in - [%log.debug "Head.find -> %a" Fmt.(option Commit.pp_key) h]; - h - - let tree_and_head t = - head t >|= function - | None -> None - | Some h -> ( - match t.tree with - | Some (o, t) when Commit.equal o h -> Some (o, t) - | _ -> - t.tree <- None; - - (* the tree cache needs to be invalidated *) - let tree = Tree.import_no_check (repo t) (`Node (Commit.node h)) in - t.tree <- Some (h, tree); - Some (h, tree)) - - let tree t = - tree_and_head t >|= function - | None -> Tree.empty () - | Some (_, tree) -> (tree :> tree) - - let lift_head_diff repo fn = function - | `Removed x -> ( - Commit.of_key repo x >>= function - | None -> Lwt.return_unit - | Some x -> fn (`Removed x)) - | `Updated (x, y) -> ( - let* x = Commit.of_key repo x in - let* y = Commit.of_key repo y in - match (x, y) with - | None, None -> Lwt.return_unit - | Some x, None -> fn (`Removed x) - | None, Some y -> fn (`Added y) - | Some x, Some y -> fn (`Updated (x, y))) - | `Added x -> ( - Commit.of_key repo x >>= function - | None -> Lwt.return_unit - | Some x -> fn (`Added x)) - - let watch t ?init fn = - branch t >>= function - | None -> failwith "watch a detached head: TODO" - | Some name0 -> - let init = - match init with - | None -> None - | Some head0 -> Some [ (name0, head0.key) ] - in - let+ key = - Branch_store.watch (branch_store t) ?init (fun name head -> - if equal_branch name0 name then lift_head_diff t.repo fn head - else Lwt.return_unit) - in - fun () -> Branch_store.unwatch (branch_store t) key - - let watch_key t key ?init fn = - [%log.debug "watch-key %a" pp_path key]; - let tree c = Tree.find_tree (Commit.tree c) key in - watch t ?init (lift_tree_diff ~key tree fn) - - module Head = struct - let list = Repo.heads - let find = head - - let get t = - find t >>= function None -> err_no_head "head" | Some k -> Lwt.return k - - let set t c = - match t.head_ref with - | `Head h -> - h := Some c; - Lwt.return_unit - | `Branch name -> Branch_store.set (branch_store t) name c.key - - let test_and_set_unsafe t ~test ~set = - match t.head_ref with - | `Head head -> - (* [head] is protected by [t.lock]. *) - if Commit.equal_opt !head test then ( - head := set; - Lwt.return_true) - else Lwt.return_false - | `Branch name -> - let h = function None -> None | Some c -> Some c.key in - Branch_store.test_and_set (branch_store t) name ~test:(h test) - ~set:(h set) - - let test_and_set t ~test ~set = - Lwt_mutex.with_lock t.lock (fun () -> test_and_set_unsafe t ~test ~set) - - let fast_forward t ?max_depth ?n new_head = - let return x = if x then Ok () else Error (`Rejected :> ff_error) in - find t >>= function - | None -> test_and_set t ~test:None ~set:(Some new_head) >|= return - | Some old_head -> ( - [%log.debug - "fast-forward-head old=%a new=%a" Commit.pp_hash old_head - Commit.pp_hash new_head]; - if Commit.equal new_head old_head then - (* we only update if there is a change *) - Lwt.return (Error `No_change) - else - Commits.lcas (commit_store t) ?max_depth ?n new_head.key - old_head.key - >>= function - | Ok [ x ] when equal_commit_key x old_head.key -> - (* we only update if new_head > old_head *) - test_and_set t ~test:(Some old_head) ~set:(Some new_head) - >|= return - | Ok _ -> Lwt.return (Error `Rejected) - | Error e -> Lwt.return (Error (e :> ff_error))) - - (* Merge two commits: - - Search for common ancestors - - Perform recursive 3-way merges *) - let three_way_merge t ?max_depth ?n ~info c1 c2 = - B.Repo.batch (repo t) @@ fun _ _ commit_t -> - Commits.three_way_merge commit_t ?max_depth ?n ~info c1.key c2.key - - (* FIXME: we might want to keep the new commit in case of conflict, - and use it as a base for the next merge. *) - let merge ~into:t ~info ?max_depth ?n c1 = - [%log.debug "merge_head"]; - let aux () = - let* head = head t in - match head with - | None -> test_and_set_unsafe t ~test:head ~set:(Some c1) >>= Merge.ok - | Some c2 -> - three_way_merge t ~info ?max_depth ?n c1 c2 >>=* fun c3 -> - let* c3 = Commit.of_key t.repo c3 in - test_and_set_unsafe t ~test:head ~set:c3 >>= Merge.ok - in - Lwt_mutex.with_lock t.lock (fun () -> retry_merge "merge_head" aux) - end - - (* Retry an operation until the optimistic lock is happy. Ensure - that the operation is done at least once. *) - let retry ~retries fn = - let done_once = ref false in - let rec aux i = - if !done_once && i > retries then - Lwt.return (Error (`Too_many_retries retries)) - else - fn () >>= function - | Ok (c, true) -> Lwt.return (Ok c) - | Error e -> Lwt.return (Error e) - | Ok (_, false) -> - done_once := true; - aux (i + 1) - in - aux 0 - - let root_tree = function - | `Node _ as n -> Tree.v n - | `Contents _ -> assert false - - let add_commit t old_head ((c, _) as tree) = - match t.head_ref with - | `Head head -> - Lwt_mutex.with_lock t.lock (fun () -> - if not (Commit.equal_opt old_head !head) then Lwt.return_false - else ( - (* [head] is protected by [t.lock] *) - head := Some c; - t.tree <- Some tree; - Lwt.return_true)) - | `Branch name -> - (* concurrent handlers and/or process can modify the - branch. Need to check that we are still working on the same - head. *) - let test = match old_head with None -> None | Some c -> Some c.key in - let set = Some c.key in - let+ r = Branch_store.test_and_set (branch_store t) name ~test ~set in - if r then t.tree <- Some tree; - r - - let pp_write_error ppf = function - | `Conflict e -> Fmt.pf ppf "Got a conflict: %s" e - | `Too_many_retries i -> - Fmt.pf ppf - "Failure after %d attempts to retry the operation: Too many attempts." - i - | `Test_was t -> - Fmt.pf ppf "Test-and-set failed: got %a when reading the store" - Fmt.(Dump.option pp_tree) - t - - let write_error e : ('a, write_error) result Lwt.t = Lwt.return (Error e) - let err_test v = write_error (`Test_was v) - - type snapshot = { - head : commit option; - root : tree; - tree : tree option; - (* the subtree used by the transaction *) - parents : commit list; - } - - let snapshot t key = - tree_and_head t >>= function - | None -> - Lwt.return - { head = None; root = Tree.empty (); tree = None; parents = [] } - | Some (c, root) -> - let root = (root :> tree) in - let+ tree = Tree.find_tree root key in - { head = Some c; root; tree; parents = [ c ] } - - let same_tree x y = - match (x, y) with - | None, None -> true - | None, _ | _, None -> false - | Some x, Some y -> Tree.equal x y - - (* Update the store with a new commit. Ensure the no commit becomes orphan - in the process. *) - let update ?(clear = true) ?(allow_empty = false) ~info ?parents t key - merge_tree f = - let* s = snapshot t key in - (* this might take a very long time *) - let* new_tree = f s.tree in - (* if no change and [allow_empty = true] then, do nothing *) - if same_tree s.tree new_tree && (not allow_empty) && s.head <> None then - Lwt.return (Ok (None, true)) - else - merge_tree s.root key ~current_tree:s.tree ~new_tree >>= function - | Error e -> Lwt.return (Error e) - | Ok root -> - let info = info () in - let parents = match parents with None -> s.parents | Some p -> p in - let parents = List.map Commit.key parents in - let* c = Commit.v ~clear (repo t) ~info ~parents root in - let* r = add_commit t s.head (c, root_tree (Tree.destruct root)) in - Lwt.return (Ok (Some c, r)) - - let ok x = Ok x - - let fail name = function - | Ok x -> Lwt.return x - | Error e -> Fmt.kstr Lwt.fail_with "%s: %a" name pp_write_error e - - let set_tree_once root key ~current_tree:_ ~new_tree = - match new_tree with - | None -> Tree.remove root key >|= ok - | Some tree -> Tree.add_tree root key tree >|= ok - - let ignore_commit - (c : (commit option, [> `Too_many_retries of int ]) result Lwt.t) = - Lwt_result.map (fun _ -> ()) c - - let set_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t k v = - [%log.debug "set %a" pp_path k]; - ignore_commit - @@ retry ~retries - @@ fun () -> - update t k ?clear ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> - Lwt.return_some v - - let set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k v = - set_tree ?clear ?retries ?allow_empty ?parents ~info t k v - >>= fail "set_exn" - - let remove ?clear ?(retries = 13) ?allow_empty ?parents ~info t k = - [%log.debug "debug %a" pp_path k]; - ignore_commit - @@ retry ~retries - @@ fun () -> - update t k ?clear ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> - Lwt.return_none - - let remove_exn ?clear ?retries ?allow_empty ?parents ~info t k = - remove ?clear ?retries ?allow_empty ?parents ~info t k >>= fail "remove_exn" - - let set ?clear ?retries ?allow_empty ?parents ~info t k v = - let v = Tree.of_contents v in - set_tree t k ?clear ?retries ?allow_empty ?parents ~info v - - let set_exn ?clear ?retries ?allow_empty ?parents ~info t k v = - set t k ?clear ?retries ?allow_empty ?parents ~info v >>= fail "set_exn" - - let test_and_set_tree_once ~test root key ~current_tree ~new_tree = - match (test, current_tree) with - | None, None -> set_tree_once root key ~new_tree ~current_tree - | None, _ | _, None -> err_test current_tree - | Some test, Some v -> - if Tree.equal test v then set_tree_once root key ~new_tree ~current_tree - else err_test current_tree - - let test_set_and_get_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t - k ~test ~set = - [%log.debug "test-and-set %a" pp_path k]; - retry ~retries @@ fun () -> - update t k ?clear ?allow_empty ?parents ~info (test_and_set_tree_once ~test) - @@ fun _tree -> Lwt.return set - - let test_set_and_get_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k - ~test ~set = - test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test - ~set - >>= fail "test_set_and_get_tree_exn" - - let test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test - ~set = - let test = Option.map Tree.of_contents test in - let set = Option.map Tree.of_contents set in - test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test - ~set - - let test_set_and_get_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test - ~set = - test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set - >>= fail "test_set_and_get_exn" - - let test_and_set_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t k - ~test ~set = - [%log.debug "test-and-set %a" pp_path k]; - ignore_commit - @@ test_set_and_get_tree ~retries ?clear ?allow_empty ?parents ~info t k - ~test ~set - - let test_and_set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k - ~test ~set = - test_and_set_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set - >>= fail "test_and_set_tree_exn" - - let test_and_set ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set = - ignore_commit - @@ test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test - ~set - - let test_and_set_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test - ~set = - test_and_set ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set - >>= fail "test_and_set_exn" - - let merge_once ~old root key ~current_tree ~new_tree = - let old = Merge.promise old in - Merge.f (Merge.option Tree.merge) ~old current_tree new_tree >>= function - | Ok tr -> set_tree_once root key ~new_tree:tr ~current_tree - | Error e -> write_error (e :> write_error) - - let merge_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info ~old t k - tree = - [%log.debug "merge %a" pp_path k]; - ignore_commit - @@ retry ~retries - @@ fun () -> - update t k ?clear ?allow_empty ?parents ~info (merge_once ~old) - @@ fun _tree -> Lwt.return tree - - let merge_tree_exn ?clear ?retries ?allow_empty ?parents ~info ~old t k tree = - merge_tree ?clear ?retries ?allow_empty ?parents ~info ~old t k tree - >>= fail "merge_tree_exn" - - let merge ?clear ?retries ?allow_empty ?parents ~info ~old t k v = - let old = Option.map Tree.of_contents old in - let v = Option.map Tree.of_contents v in - merge_tree ?clear ?retries ?allow_empty ?parents ~info ~old t k v - - let merge_exn ?clear ?retries ?allow_empty ?parents ~info ~old t k v = - merge ?clear ?retries ?allow_empty ?parents ~info ~old t k v - >>= fail "merge_exn" - - let mem t k = tree t >>= fun tree -> Tree.mem tree k - let mem_tree t k = tree t >>= fun tree -> Tree.mem_tree tree k - let find_all t k = tree t >>= fun tree -> Tree.find_all tree k - let find t k = tree t >>= fun tree -> Tree.find tree k - let get t k = tree t >>= fun tree -> Tree.get tree k - let find_tree t k = tree t >>= fun tree -> Tree.find_tree tree k - let get_tree t k = tree t >>= fun tree -> Tree.get_tree tree k - - let key t k = - find_tree t k >|= function - | None -> None - | Some tree -> ( - match Tree.key tree with - | Some (`Contents (key, _)) -> Some (`Contents key) - | Some (`Node key) -> Some (`Node key) - | None -> None) - - let hash t k = - find_tree t k >|= function - | None -> None - | Some tree -> Some (Tree.hash tree) - - let get_all t k = tree t >>= fun tree -> Tree.get_all tree k - let list t k = tree t >>= fun tree -> Tree.list tree k - let kind t k = tree t >>= fun tree -> Tree.kind tree k - - let with_tree ?clear ?(retries = 13) ?allow_empty ?parents - ?(strategy = `Test_and_set) ~info t key f = - let done_once = ref false in - let rec aux n old_tree = - [%log.debug "with_tree %a (%d/%d)" pp_path key n retries]; - if !done_once && n > retries then write_error (`Too_many_retries retries) - else - let* new_tree = f old_tree in - match (strategy, new_tree) with - | `Set, Some tree -> - set_tree ?clear t key ~retries ?allow_empty ?parents tree ~info - | `Set, None -> remove ?clear t key ~retries ?allow_empty ~info ?parents - | `Test_and_set, _ -> ( - test_and_set_tree ?clear t key ~retries ?allow_empty ?parents ~info - ~test:old_tree ~set:new_tree - >>= function - | Error (`Test_was tr) when retries > 0 && n <= retries -> - done_once := true; - aux (n + 1) tr - | e -> Lwt.return e) - | `Merge, _ -> ( - merge_tree ?clear ~old:old_tree ~retries ?allow_empty ?parents ~info - t key new_tree - >>= function - | Ok _ as x -> Lwt.return x - | Error (`Conflict _) when retries > 0 && n <= retries -> - done_once := true; - - (* use the store's current tree as the new 'old store' *) - let* old_tree = - tree_and_head t >>= function - | None -> Lwt.return_none - | Some (_, tr) -> Tree.find_tree (tr :> tree) key - in - aux (n + 1) old_tree - | Error e -> write_error e) - in - let* old_tree = find_tree t key in - aux 0 old_tree - - let with_tree_exn ?clear ?retries ?allow_empty ?parents ?strategy ~info f t - key = - with_tree ?clear ?retries ?allow_empty ?strategy ?parents ~info f t key - >>= fail "with_tree_exn" - - let clone ~src ~dst = - let* () = - Head.find src >>= function - | None -> Branch_store.remove (branch_store src) dst - | Some h -> Branch_store.set (branch_store src) dst h.key - in - of_branch (repo src) dst - - let return_lcas r = function - | Error _ as e -> Lwt.return e - | Ok commits -> - Lwt_list.filter_map_p (Commit.of_key r) commits >|= Result.ok - - let lcas ?max_depth ?n t1 t2 = - let* h1 = Head.get t1 in - let* h2 = Head.get t2 in - Commits.lcas (commit_store t1) ?max_depth ?n h1.key h2.key - >>= return_lcas t1.repo - - let lcas_with_commit t ?max_depth ?n c = - let* h = Head.get t in - Commits.lcas (commit_store t) ?max_depth ?n h.key c.key - >>= return_lcas t.repo - - let lcas_with_branch t ?max_depth ?n b = - let* h = Head.get t in - let* head = Head.get { t with head_ref = `Branch b } in - Commits.lcas (commit_store t) ?max_depth ?n h.key head.key - >>= return_lcas t.repo - - type 'a merge = - info:Info.f -> - ?max_depth:int -> - ?n:int -> - 'a -> - (unit, Merge.conflict) result Lwt.t - - let merge_with_branch t ~info ?max_depth ?n other = - [%log.debug "merge_with_branch %a" pp_branch other]; - Branch_store.find (branch_store t) other >>= function - | None -> - Fmt.kstr Lwt.fail_invalid_arg - "merge_with_branch: %a is not a valid branch ID" pp_branch other - | Some c -> ( - Commit.of_key t.repo c >>= function - | None -> Lwt.fail_invalid_arg "invalid commit" - | Some c -> Head.merge ~into:t ~info ?max_depth ?n c) - - let merge_with_commit t ~info ?max_depth ?n other = - Head.merge ~into:t ~info ?max_depth ?n other - - let merge_into ~into ~info ?max_depth ?n t = - [%log.debug "merge"]; - match head_ref t with - | `Branch name -> merge_with_branch into ~info ?max_depth ?n name - | `Head h -> merge_with_commit into ~info ?max_depth ?n h - | `Empty -> Merge.ok () - - module History = OCamlGraph.Persistent.Digraph.ConcreteBidirectional (struct - type t = commit - - let hash h = B.Hash.short_hash (Commit.hash h) - let compare_key = Type.(unstage (compare B.Commit.Key.t)) - let compare x y = compare_key x.key y.key - let equal x y = equal_commit_key x.key y.key - end) - - module Gmap = struct - module Src = KGraph - - module Dst = struct - include History - - let empty () = empty - end - - let filter_map f g = - let t = Dst.empty () in - if Src.nb_vertex g = 1 then - match Src.vertex g with - | [ v ] -> ( - f v >|= function Some v -> Dst.add_vertex t v | None -> t) - | _ -> assert false - else - Src.fold_edges - (fun x y t -> - let* t = t in - let* x = f x in - let+ y = f y in - match (x, y) with - | Some x, Some y -> - let t = Dst.add_vertex t x in - let t = Dst.add_vertex t y in - Dst.add_edge t x y - | _ -> t) - g (Lwt.return t) - end - - let history ?depth ?(min = []) ?(max = []) t = - [%log.debug "history"]; - let pred = function - | `Commit k -> - Commits.parents (commit_store t) k - >>= Lwt_list.filter_map_p (Commit.of_key t.repo) - >|= fun parents -> List.map (fun x -> `Commit x.key) parents - | _ -> Lwt.return_nil - in - let* max = Head.find t >|= function Some h -> [ h ] | None -> max in - let max = List.map (fun k -> `Commit k.key) max in - let min = List.map (fun k -> `Commit k.key) min in - let* g = Gmap.Src.closure ?depth ~min ~max ~pred () in - Gmap.filter_map - (function `Commit k -> Commit.of_key t.repo k | _ -> Lwt.return_none) - g - - module Heap = Binary_heap.Make (struct - type t = commit * int - - let compare c1 c2 = - (* [bheap] operates on miminums, we need to invert the comparison. *) - -Int64.compare - (Info.date (Commit.info (fst c1))) - (Info.date (Commit.info (fst c2))) - end) - - let last_modified ?depth ?(n = 1) t key = - [%log.debug - "last_modified depth=%a n=%d key=%a" - Fmt.(Dump.option pp_int) - depth n pp_path key]; - let repo = repo t in - let* commit = Head.get t in - let heap = Heap.create ~dummy:(commit, 0) 0 in - let () = Heap.add heap (commit, 0) in - let rec search acc = - if Heap.is_empty heap || List.length acc = n then Lwt.return acc - else - let current, current_depth = Heap.pop_minimum heap in - let parents = Commit.parents current in - let tree = Commit.tree current in - let* current_value = Tree.find tree key in - if List.length parents = 0 then - if current_value <> None then Lwt.return (current :: acc) - else Lwt.return acc - else - let max_depth = - match depth with - | Some depth -> current_depth >= depth - | None -> false - in - let* found = - Lwt_list.for_all_p - (fun hash -> - Commit.of_key repo hash >>= function - | Some commit -> ( - let () = - if not max_depth then - Heap.add heap (commit, current_depth + 1) - in - let tree = Commit.tree commit in - let+ e = Tree.find tree key in - match (e, current_value) with - | Some x, Some y -> not (equal_contents x y) - | Some _, None -> true - | None, Some _ -> true - | _, _ -> false) - | None -> Lwt.return_false) - parents - in - if found then search (current :: acc) else search acc - in - search [] - - module Branch = struct - include B.Branch.Key - - let mem t = B.Branch.mem (B.Repo.branch_t t) - - let find t br = - B.Branch.find (Repo.branch_t t) br >>= function - | None -> Lwt.return_none - | Some h -> Commit.of_key t h - - let set t br h = B.Branch.set (B.Repo.branch_t t) br h.key - let remove t = B.Branch.remove (B.Repo.branch_t t) - let list = Repo.branches - - let watch t k ?init f = - let init = match init with None -> None | Some h -> Some h.key in - let+ w = - B.Branch.watch_key (Repo.branch_t t) k ?init (lift_head_diff t f) - in - fun () -> Branch_store.unwatch (Repo.branch_t t) w - - let watch_all t ?init f = - let init = - match init with - | None -> None - | Some i -> Some (List.map (fun (k, v) -> (k, v.key)) i) - in - let f k v = lift_head_diff t (f k) v in - let+ w = B.Branch.watch (Repo.branch_t t) ?init f in - fun () -> Branch_store.unwatch (Repo.branch_t t) w - - let err_not_found k = - Fmt.kstr invalid_arg "Branch.get: %a not found" pp_branch k - - let get t k = - find t k >>= function None -> err_not_found k | Some v -> Lwt.return v - - let pp = pp_branch - end - - module Status = struct - type t = [ `Empty | `Branch of branch | `Commit of commit ] - - let t r = - let open Type in - variant "status" (fun empty branch commit -> function - | `Empty -> empty - | `Branch b -> branch b - | `Commit c -> commit c) - |~ case0 "empty" `Empty - |~ case1 "branch" Branch.t (fun b -> `Branch b) - |~ case1 "commit" (Commit.t r) (fun c -> `Commit c) - |> sealv - - let pp ppf = function - | `Empty -> Fmt.string ppf "empty" - | `Branch b -> pp_branch ppf b - | `Commit c -> pp_hash ppf (Commit_key.to_hash c.key) - end - - let commit_t = Commit.t -end - module Json_tree (Store : S with type Schema.Contents.t = Contents.json) = struct include Contents.Json_value diff --git a/src/irmin-lwt/core/store_intf.ml b/src/irmin-lwt/core/store_intf.ml index b75118d3d9..34ca56b18e 100644 --- a/src/irmin-lwt/core/store_intf.ml +++ b/src/irmin-lwt/core/store_intf.ml @@ -1236,16 +1236,6 @@ module type Sigs = sig type Remote.t += | Store : (module Generic_key.S with type t = 'a) * 'a -> Remote.t - module Make (B : Backend.S) : - Generic_key.S - with module Schema = B.Schema - and type slice = B.Slice.t - and type repo = B.Repo.t - and type contents_key = B.Contents.key - and type node_key = B.Node.key - and type commit_key = B.Commit.key - and module Backend = B - 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 diff --git a/src/irmin-lwt/core/tree.ml b/src/irmin-lwt/core/tree.ml index f3dc36721d..71bebe142d 100644 --- a/src/irmin-lwt/core/tree.ml +++ b/src/irmin-lwt/core/tree.ml @@ -15,2816 +15,15 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open! Import -include Tree_intf - -let src = Logs.Src.create "irmin.tree" ~doc:"Persistent lazy trees for Irmin" - -module Log = (val Logs.src_log src : Logs.LOG) - -type fuzzy_bool = False | True | Maybe -type ('a, 'r) cont = ('a -> 'r) -> 'r -type ('a, 'r) cont_lwt = ('a, 'r Lwt.t) cont - -let ok x = Lwt.return (Ok 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 [@tailcall]) t1 t2 - | x -> - if x < 0 then ( - f k1 (`Left v1); - (aux [@tailcall]) t1 l2) - else ( - f k2 (`Right v2); - (aux [@tailcall]) l1 t2)) - in - aux l1 l2 - -(* assume l1 and l2 are key-sorted *) -let alist_iter2_lwt compare_k f l1 l2 = - let l3 = ref [] in - alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; - Lwt_list.iter_s (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !l3) - -exception Backend_invariant_violation of string -exception Assertion_failure of string - -let backend_invariant_violation fmt = - Fmt.kstr (fun s -> raise (Backend_invariant_violation s)) fmt - -let assertion_failure fmt = Fmt.kstr (fun s -> raise (Assertion_failure s)) fmt - -module Make (P : Backend.S) = struct - 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; - } - [@@deriving irmin] - - let dump_counters ppf t = Type.pp_json ~minify:false counters_t ppf t - - let fresh_counters () = - { - contents_hash = 0; - contents_add = 0; - contents_find = 0; - contents_mem = 0; - node_hash = 0; - node_mem = 0; - node_index = 0; - node_add = 0; - node_find = 0; - node_val_v = 0; - node_val_find = 0; - node_val_list = 0; - } - - let reset_counters t = - t.contents_hash <- 0; - t.contents_add <- 0; - t.contents_find <- 0; - t.contents_mem <- 0; - t.node_hash <- 0; - t.node_mem <- 0; - t.node_index <- 0; - t.node_add <- 0; - t.node_find <- 0; - t.node_val_v <- 0; - t.node_val_find <- 0; - t.node_val_list <- 0 - - let cnt = fresh_counters () - - module Path = struct - include P.Node.Path - - let fold_right t ~f ~init = - let steps = map t Fun.id in - List.fold_right f steps init - end - - module Metadata = P.Node.Metadata - module Irmin_proof = Proof - module Tree_proof = Proof.Make (P.Contents.Val) (P.Hash) (Path) (Metadata) - module Env = Proof.Env (P) (Tree_proof) - - let merge_env x y = - match (Env.is_empty x, Env.is_empty y) with - | true, _ -> Ok y - | _, true -> Ok x - | false, false -> Error (`Conflict "merge env") - - module Hashes = Hash.Set.Make (P.Hash) - - module StepMap = struct - module X = struct - type t = Path.step [@@deriving irmin ~compare] - end - - include Map.Make (X) - - let stdlib_merge = merge - - include Merge.Map (X) - - let to_array m = - let length = cardinal m in - if length = 0 then [||] - else - let arr = Array.make length (choose m) in - let (_ : int) = - fold - (fun k v i -> - arr.(i) <- (k, v); - i + 1) - m 0 - in - arr - end - - type metadata = Metadata.t [@@deriving irmin ~equal] - type path = Path.t [@@deriving irmin ~pp] - type hash = P.Hash.t [@@deriving irmin ~pp ~equal ~compare] - type step = Path.step [@@deriving irmin ~pp ~compare] - type contents = P.Contents.Val.t [@@deriving irmin ~equal ~pp] - type repo = P.Repo.t - type marks = Hashes.t - - type error = - [ `Dangling_hash of hash | `Pruned_hash of hash | `Portable_value ] - - type 'a or_error = ('a, error) result - 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 ] - [@@deriving irmin] - - let dummy_marks = Hashes.create ~initial_slots:0 () - let empty_marks () = Hashes.create ~initial_slots:39 () - - exception Pruned_hash of { context : string; hash : hash } - exception Dangling_hash of { context : string; hash : hash } - exception Portable_value of { context : string } - - let () = - Printexc.register_printer (function - | Dangling_hash { context; hash } -> - Some - (Fmt.str "Irmin.Tree.%s: encountered dangling hash %a" context - pp_hash hash) - | Pruned_hash { context; hash } -> - Some - (Fmt.str "Irmin.Tree.%s: encountered pruned hash %a" context pp_hash - hash) - | Portable_value { context } -> - Some - (Fmt.str "Irmin.Tree.%s: unsupported operation on portable tree." - context) - | _ -> None) - - let err_pruned_hash h = Error (`Pruned_hash h) - let err_dangling_hash h = Error (`Dangling_hash h) - let err_portable_value = Error `Portable_value - let pruned_hash_exn context hash = raise (Pruned_hash { context; hash }) - let portable_value_exn context = raise (Portable_value { context }) - - let get_ok : type a. string -> a or_error -> a = - fun context -> function - | Ok x -> x - | Error (`Pruned_hash hash) -> pruned_hash_exn context hash - | Error (`Dangling_hash hash) -> raise (Dangling_hash { context; hash }) - | Error `Portable_value -> portable_value_exn context - - type 'key ptr_option = Key of 'key | Hash of hash | Ptr_none - (* NOTE: given the choice, we prefer caching [Key] over [Hash] as it can - be used to avoid storing duplicate contents values on export. *) - - module Contents = struct - type key = P.Contents.Key.t [@@deriving irmin] - type v = Key of repo * key | Value of contents | Pruned of hash - type nonrec ptr_option = key ptr_option - - type info = { - mutable ptr : ptr_option; - mutable value : contents option; - env : Env.t; - } - - type t = { mutable v : v; info : info } - - let info_is_empty i = i.ptr = Ptr_none && i.value = None - - let v = - let open Type in - variant "Node.Contents.v" (fun key value pruned (v : v) -> - match v with - | Key (_, x) -> key x - | Value v -> value v - | Pruned h -> pruned h) - |~ case1 "key" P.Contents.Key.t (fun _ -> assert false) - |~ case1 "value" P.Contents.Val.t (fun v -> Value v) - |~ case1 "pruned" hash_t (fun h -> Pruned h) - |> sealv - - let clear_info i = - if not (info_is_empty i) then ( - i.value <- None; - i.ptr <- Ptr_none) - - let clear t = clear_info t.info - - let of_v ~env (v : v) = - let ptr, value = - match v with - | Key (_, k) -> ((Key k : ptr_option), None) - | Value v -> (Ptr_none, Some v) - | Pruned _ -> (Ptr_none, None) - in - let info = { ptr; value; env } in - { v; info } - - let export ?clear:(c = true) repo t k = - let ptr = t.info.ptr in - if c then clear t; - match (t.v, ptr) with - | Key (repo', _), (Ptr_none | Hash _) -> - if repo != repo' then t.v <- Key (repo, k) - | Key (repo', _), Key k -> if repo != repo' then t.v <- Key (repo, k) - | Value _, (Ptr_none | Hash _) -> t.v <- Key (repo, k) - | Value _, Key k -> t.v <- Key (repo, k) - | Pruned _, _ -> - (* The main export function never exports a pruned position. *) - assert false - - let of_value c = of_v (Value c) - let of_key repo k = of_v (Key (repo, k)) - let pruned h = of_v (Pruned h) - - let cached_hash t = - match (t.v, t.info.ptr) with - | Key (_, k), _ -> Some (P.Contents.Key.to_hash k) - | Value _, Key k -> Some (P.Contents.Key.to_hash k) - | Pruned h, _ -> Some h - | Value _, Hash h -> Some h - | Value _, Ptr_none -> None - - let cached_key t = - match (t.v, t.info.ptr) with - | Key (_, k), _ -> Some k - | (Value _ | Pruned _), Key k -> Some k - | (Value _ | Pruned _), (Hash _ | Ptr_none) -> None - - let cached_value t = - match (t.v, t.info.value) with - | Value v, None -> Some v - | (Key _ | Value _ | Pruned _), (Some _ as v) -> v - | (Key _ | Pruned _), None -> ( - match cached_hash t with - | None -> None - | Some h -> ( - match Env.find_contents t.info.env h with - | None -> None - | Some c -> Some c)) - - let hash ?(cache = true) c = - match cached_hash c with - | Some k -> k - | None -> ( - match cached_value c with - | None -> assert false - | Some v -> - cnt.contents_hash <- cnt.contents_hash + 1; - let h = P.Contents.Hash.hash v in - assert (c.info.ptr = Ptr_none); - if cache then c.info.ptr <- Hash h; - h) - - let key t = - match t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None - - let value_of_key ~cache t repo k = - cnt.contents_find <- cnt.contents_find + 1; - let h = P.Contents.Key.to_hash k in - let+ v_opt = P.Contents.find (P.Repo.contents_t repo) k in - Option.iter (Env.add_contents_from_store t.info.env h) v_opt; - match v_opt with - | None -> err_dangling_hash h - | Some v -> - if cache then t.info.value <- v_opt; - Ok v - - let to_value ~cache t = - match cached_value t with - | Some v -> ok v - | None -> ( - match t.v with - | Value _ -> assert false (* [cached_value == None] *) - | Key (repo, k) -> value_of_key ~cache t repo k - | Pruned h -> err_pruned_hash h |> Lwt.return) - - let force = to_value ~cache:true - - let force_exn t = - let+ v = force t in - get_ok "force" v - - let equal (x : t) (y : t) = - x == y - || - match (cached_hash x, cached_hash y) with - | Some x, Some y -> equal_hash x y - | _ -> ( - match (cached_value x, cached_value y) with - | Some x, Some y -> equal_contents x y - | _ -> equal_hash (hash ~cache:true x) (hash ~cache:true y)) - - let compare (x : t) (y : t) = - if x == y then 0 - else compare_hash (hash ~cache:true x) (hash ~cache:true y) - - let t = - let of_v v = of_v ~env:(Env.empty ()) v in - Type.map ~equal ~compare v of_v (fun t -> t.v) - - let merge : t Merge.t = - let f ~old x y = - let old = - Merge.bind_promise old (fun old () -> - let+ c = to_value ~cache:true old >|= Option.of_result in - Ok (Some c)) - in - match merge_env x.info.env y.info.env with - | Error _ as e -> Lwt.return e - | Ok env -> ( - let* x = to_value ~cache:true x >|= Option.of_result in - let* y = to_value ~cache:true y >|= Option.of_result in - Merge.(f P.Contents.Val.merge) ~old x y >|= function - | Ok (Some c) -> Ok (of_value ~env c) - | Ok None -> Error (`Conflict "empty contents") - | Error _ as e -> e) - in - Merge.v t f - - let fold ~force ~cache ~path f_value f_tree t acc = - match force with - | `True -> - let* c = to_value ~cache t in - f_value path (get_ok "fold" c) acc >>= f_tree path - | `False skip -> ( - match cached_value t with - | None -> skip path acc - | Some c -> f_value path c acc >>= f_tree path) - end - - module Node = struct - type value = P.Node.Val.t [@@deriving irmin ~equal ~pp] - type key = P.Node.Key.t [@@deriving irmin] - type nonrec ptr_option = key ptr_option - - open struct - module Portable = P.Node_portable - end - - type portable = Portable.t [@@deriving irmin ~equal ~pp] - - (* [elt] is a tree *) - type elt = [ `Node of t | `Contents of Contents.t * Metadata.t ] - and update = Add of elt | Remove - and updatemap = update StepMap.t - and map = elt StepMap.t - - and info = { - mutable value : value option; - mutable map : map option; - mutable ptr : ptr_option; - mutable findv_cache : map option; - mutable length : int Lazy.t option; - env : Env.t; - } - - and v = - | Map of map - | Key of repo * key - | Value of repo * value * updatemap option - | Portable_dirty of portable * updatemap - | Pruned of hash - - and t = { mutable v : v; info : info } - (** For discussion of [t.v]'s states, see {!Tree_intf.S.inspect}. - - [t.info.map] is only populated during a call to [Node.to_map]. *) - - let elt_t (t : t Type.t) : elt Type.t = - let open Type in - variant "Node.value" (fun node contents contents_m -> function - | `Node x -> node x - | `Contents (c, m) -> - if equal_metadata m Metadata.default then contents c - else contents_m (c, m)) - |~ case1 "Node" t (fun x -> `Node x) - |~ case1 "Contents" Contents.t (fun x -> `Contents (x, Metadata.default)) - |~ case1 "Contents-x" (pair Contents.t Metadata.t) (fun x -> `Contents x) - |> sealv - - let stepmap_t : 'a. 'a Type.t -> 'a StepMap.t Type.t = - fun elt -> - let open Type in - let to_map x = - List.fold_left (fun acc (k, v) -> StepMap.add k v acc) StepMap.empty x - in - let of_map m = StepMap.fold (fun k v acc -> (k, v) :: acc) m [] in - map (list (pair Path.step_t elt)) to_map of_map - - let update_t (elt : elt Type.t) : update Type.t = - let open Type in - variant "Node.update" (fun add remove -> function - | Add elt -> add elt - | Remove -> remove) - |~ case1 "add" elt (fun elt -> Add elt) - |~ case0 "remove" Remove - |> sealv - - let v_t (elt : elt Type.t) : v Type.t = - let m = stepmap_t elt in - let um = stepmap_t (update_t elt) in - let open Type in - variant "Node.node" (fun map key value pruned portable_dirty -> function - | Map m -> map m - | Key (_, y) -> key y - | Value (_, v, m) -> value (v, m) - | Pruned h -> pruned h - | Portable_dirty (v, m) -> portable_dirty (v, m)) - |~ case1 "map" m (fun m -> Map m) - |~ case1 "key" P.Node.Key.t (fun _ -> assert false) - |~ case1 "value" (pair P.Node.Val.t (option um)) (fun _ -> assert false) - |~ case1 "pruned" hash_t (fun h -> Pruned h) - |~ case1 "portable_dirty" (pair portable_t um) (fun (v, m) -> - Portable_dirty (v, m)) - |> sealv - - let of_v ?length ~env v = - let ptr, map, value = - match v with - | Map m -> (Ptr_none, Some m, None) - | Key (_, k) -> (Key k, None, None) - | Value (_, v, None) -> (Ptr_none, None, Some v) - | Value _ | Portable_dirty _ | Pruned _ -> (Ptr_none, None, None) - in - let findv_cache = None in - let info = { ptr; map; value; findv_cache; env; length } in - { v; info } - - let of_map m = of_v (Map m) - let of_key repo k = of_v (Key (repo, k)) - - let of_value ?length ?updates repo v = - of_v ?length (Value (repo, v, updates)) - - let of_portable_dirty p updates = of_v (Portable_dirty (p, updates)) - let pruned h = of_v (Pruned h) - - let info_is_empty i = - i.map = None && i.value = None && i.findv_cache = None && i.ptr = Ptr_none - - let add_to_findv_cache t step v = - match t.info.findv_cache with - | None -> t.info.findv_cache <- Some (StepMap.singleton step v) - | Some m -> t.info.findv_cache <- Some (StepMap.add step v m) - - let clear_info_fields i = - if not (info_is_empty i) then ( - i.value <- None; - i.map <- None; - i.ptr <- Ptr_none; - i.findv_cache <- None) - - let rec clear_elt ~max_depth depth v = - match v with - | `Contents (c, _) -> if depth + 1 > max_depth then Contents.clear c - | `Node t -> clear ~max_depth (depth + 1) t - - and clear_info ~max_depth ~v depth i = - let clear _ v = clear_elt ~max_depth depth v in - let () = - match v with - | Value (_, _, Some um) -> - StepMap.iter - (fun k -> function Remove -> () | Add v -> clear k v) - um - | Value (_, _, None) | Map _ | Key _ | Portable_dirty _ | Pruned _ -> () - in - let () = - match (v, i.map) with - | Map m, _ | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> - StepMap.iter clear m - | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> () - in - let () = - match i.findv_cache with Some m -> StepMap.iter clear m | None -> () - in - if depth >= max_depth then clear_info_fields i - - and clear ~max_depth depth t = clear_info ~v:t.v ~max_depth depth t.info - - (* export t to the given repo and clear the cache *) - let export ?clear:(c = true) repo t k = - let ptr = t.info.ptr in - if c then clear_info_fields t.info; - match t.v with - | Key (repo', k) -> if repo != repo' then t.v <- Key (repo, k) - | Value _ | Map _ -> ( - match ptr with - | Ptr_none | Hash _ -> t.v <- Key (repo, k) - | Key k -> t.v <- Key (repo, k)) - | Portable_dirty _ | Pruned _ -> - (* The main export function never exports a pruned position. *) - assert false - - module Core_value - (N : - Node.Generic_key.Core - with type step := step - and type hash := hash - and type metadata := metadata) - (To_elt : sig - type repo - - val t : env:Env.t -> repo -> N.value -> elt - end) = - struct - let to_map ~cache ~env repo t = - cnt.node_val_list <- cnt.node_val_list + 1; - let entries = N.seq ~cache t in - Seq.fold_left - (fun acc (k, v) -> StepMap.add k (To_elt.t ~env repo v) acc) - StepMap.empty entries - - (** Does [um] empties [v]? - - Gotcha: Some [Remove] entries in [um] might not be in [v]. *) - let is_empty_after_updates ~cache t um = - let any_add = - StepMap.to_seq um - |> Seq.exists (function _, Remove -> false | _, Add _ -> true) - in - if any_add then false - else - let val_is_empty = N.is_empty t in - if val_is_empty then true - else - let remove_count = StepMap.cardinal um in - if (not val_is_empty) && remove_count = 0 then false - else if N.length t > remove_count then false - else ( - (* Starting from this point the function is expensive, but there is - no alternative. *) - cnt.node_val_list <- cnt.node_val_list + 1; - let entries = N.seq ~cache t in - Seq.for_all (fun (step, _) -> StepMap.mem step um) entries) - - let findv ~cache ~env step node repo t = - match N.find ~cache t step with - | None -> None - | Some v -> - let tree = To_elt.t ~env repo v in - if cache then add_to_findv_cache node step tree; - Some tree - - let seq ~env ?offset ?length ~cache repo v = - cnt.node_val_list <- cnt.node_val_list + 1; - let seq = N.seq ?offset ?length ~cache v in - Seq.map (fun (k, v) -> (k, To_elt.t ~env repo v)) seq - end - - module Regular_value = - Core_value - (P.Node.Val) - (struct - type nonrec repo = repo - - let t ~env repo = function - | `Node k -> `Node (of_key ~env repo k) - | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) - end) - - module Portable_value = - Core_value - (P.Node_portable) - (struct - type repo = unit - - let t ~env () = function - | `Node h -> `Node (pruned ~env h) - | `Contents (h, m) -> `Contents (Contents.pruned ~env h, m) - end) - - (** This [Scan] module contains function that scan the content of [t.v] and - [t.info], looking for specific patterns. *) - module Scan = struct - let iter_hash t hit miss miss_arg = - match (t.v, t.info.ptr) with - | Key (_, k), _ -> hit (P.Node.Key.to_hash k) - | (Map _ | Value _ | Portable_dirty _), Key k -> - hit (P.Node.Key.to_hash k) - | Pruned h, _ -> hit h - | (Map _ | Value _ | Portable_dirty _), Hash h -> hit h - | (Map _ | Value _ | Portable_dirty _), Ptr_none -> miss t miss_arg - - let iter_key t hit miss miss_arg = - match (t.v, t.info.ptr) with - | Key (_, k), _ -> hit k - | (Map _ | Value _ | Portable_dirty _ | Pruned _), Key k -> hit k - | (Map _ | Value _ | Portable_dirty _ | Pruned _), (Hash _ | Ptr_none) - -> - miss t miss_arg - - let iter_map t hit miss miss_arg = - match (t.v, t.info.map) with - | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> hit m - | Map m, _ -> hit m - | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> - miss t miss_arg - - let iter_value t hit miss miss_arg = - match (t.v, t.info.value) with - | Value (_, v, None), None -> hit v - | (Map _ | Key _ | Value _ | Portable_dirty _ | Pruned _), Some v -> - hit v - | ( (Map _ | Key _ | Value (_, _, Some _) | Portable_dirty _ | Pruned _), - None ) -> - iter_hash t - (fun h -> - (* The need for [t], [miss] and [miss_arg] allocates a closure *) - match Env.find_node t.info.env h with - | None -> miss t miss_arg - | Some v -> hit v) - miss miss_arg - - let iter_portable t hit miss miss_arg = - match t.v with - | Pruned h -> ( - match Env.find_pnode t.info.env h with - | None -> miss t miss_arg - | Some v -> hit v) - | Map _ | Key _ | Value _ | Portable_dirty _ -> - (* No need to peek in [env]in these cases because [env] - is in practice expected to only hit on [Pruned]. *) - miss t miss_arg - - let iter_repo_key t hit miss miss_arg = - match (t.v, t.info.ptr) with - | Key (repo, k), _ -> hit repo k - | Value (repo, _, _), Key k -> hit repo k - | (Map _ | Portable_dirty _ | Pruned _ | Value _), _ -> miss t miss_arg - - let iter_repo_value t hit miss miss_arg = - match (t.v, t.info.value) with - | Value (repo, v, None), _ -> hit repo v - | (Value (repo, _, _) | Key (repo, _)), Some v -> hit repo v - | (Value (repo, _, _) | Key (repo, _)), None -> - iter_hash t - (fun h -> - match Env.find_node t.info.env h with - | None -> miss t miss_arg - | Some v -> hit repo v) - miss miss_arg - | (Map _ | Portable_dirty _ | Pruned _), _ -> miss t miss_arg - - type node = t - - (** An instance of [t] is expected to be the result of a chain of [to_*] - function calls. - - The [to_*] functions scan a [node] and look for a specific pattern. - The first function in the chain to match a pattern will return the - instance of [t] and ignore the rest of the chain. - - The functions in the chain should be carefuly ordered so that the - computation that follows is as quick as possible (e.g. if the goal is - to convert a [node] to hash, [to_hash] should be checked before - [to_map]). - - [cascade] may be used in order to build chains. *) - - type _ t = - | Hash : hash -> [> `hash ] t - | Map : map -> [> `map ] t - | Value : value -> [> `value ] t - | Value_dirty : (repo * value * updatemap) -> [> `value_dirty ] t - | Portable : portable -> [> `portable ] t - | Portable_dirty : (portable * updatemap) -> [> `portable_dirty ] t - | Pruned : hash -> [> `pruned ] t - | Repo_key : (repo * key) -> [> `repo_key ] t - | Repo_value : (repo * value) -> [> `repo_value ] t - | Any : [> `any ] t - - module View_kind = struct - type _ t = - | Hash : [> `hash ] t - | Map : [> `map ] t - | Value : [> `value ] t - | Value_dirty : [> `value_dirty ] t - | Portable : [> `portable ] t - | Portable_dirty : [> `portable_dirty ] t - | Pruned : [> `pruned ] t - | Repo_key : [> `repo_key ] t - | Repo_value : [> `repo_value ] t - | Any : [> `any ] t - end - - let to_hash t miss = iter_hash t (fun h -> Hash h) miss - let to_map t miss = iter_map t (fun m -> Map m) miss - let to_value t miss = iter_value t (fun v -> Value v) miss - let to_portable t miss = iter_portable t (fun v -> Portable v) miss - - let to_value_dirty t miss miss_arg = - match t.v with - | Value (repo, v, Some um) -> Value_dirty (repo, v, um) - | Map _ | Key _ | Value (_, _, None) | Portable_dirty _ | Pruned _ -> - miss t miss_arg - - let to_portable_dirty t miss miss_arg = - match t.v with - | Portable_dirty (v, um) -> Portable_dirty (v, um) - | Map _ | Key _ | Value _ | Pruned _ -> miss t miss_arg - - let to_pruned t miss miss_arg = - match t.v with - | Pruned h -> Pruned h - | Map _ | Key _ | Value _ | Portable_dirty _ -> miss t miss_arg - - let to_repo_key t miss miss_arg = - iter_repo_key t (fun repo k -> Repo_key (repo, k)) miss miss_arg - - let to_repo_value t miss miss_arg = - iter_repo_value t (fun repo v -> Repo_value (repo, v)) miss miss_arg - - let rec cascade : type k. node -> k View_kind.t list -> k t = - fun t -> function - | [] -> - (* The declared cascade doesn't cover all cases *) - assert false - | x :: xs -> ( - match x with - | Hash -> to_hash t cascade xs - | Map -> to_map t cascade xs - | Value -> to_value t cascade xs - | Value_dirty -> to_value_dirty t cascade xs - | Portable -> to_portable t cascade xs - | Portable_dirty -> to_portable_dirty t cascade xs - | Pruned -> to_pruned t cascade xs - | Repo_key -> to_repo_key t cascade xs - | Repo_value -> to_repo_value t cascade xs - | Any -> Any) - end - - let get_none _ () = None - let cached_hash t = Scan.iter_hash t Option.some get_none () - let cached_key t = Scan.iter_key t Option.some get_none () - let cached_map t = Scan.iter_map t Option.some get_none () - let cached_value t = Scan.iter_value t Option.some get_none () - let cached_portable t = Scan.iter_portable t Option.some get_none () - - let key t = - match t.v with - | Key (_, k) -> Some k - | Map _ | Value _ | Portable_dirty _ | Pruned _ -> None - - (* When computing hashes of nodes, we try to use [P.Node.Val.t] as a - pre-image if possible so that this intermediate value can be cached - within [t.info.value] (in case it is about to be written to the backend). - - This is only possible if all of the child pointers have pre-existing - keys, otherwise we must convert to portable nodes as a fallback. *) - type hash_preimage = Node of P.Node.Val.t | Pnode of Portable.t - type node_value = P.Node.Val.value - type pnode_value = Portable.value - - type hash_preimage_value = - | Node_value of node_value - | Pnode_value of pnode_value - - let weaken_value : node_value -> pnode_value = function - | `Contents (key, m) -> `Contents (P.Contents.Key.to_hash key, m) - | `Node key -> `Node (P.Node.Key.to_hash key) - - let rec hash : type a. cache:bool -> t -> (hash -> a) -> a = - fun ~cache t k -> - let a_of_hashable hash v = - cnt.node_hash <- cnt.node_hash + 1; - let hash = hash v in - assert (t.info.ptr = Ptr_none); - if cache then t.info.ptr <- Hash hash; - k hash - in - match - (Scan.cascade t [ Hash; Value; Value_dirty; Portable_dirty; Map ] - : [ `hash | `value | `value_dirty | `portable_dirty | `map ] Scan.t) - with - | Hash h -> k h - | Value v -> a_of_hashable P.Node.Val.hash_exn v - | Value_dirty (_repo, v, um) -> - hash_preimage_of_updates ~cache t (Node v) um (function - | Node x -> a_of_hashable P.Node.Val.hash_exn x - | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) - | Portable_dirty (p, um) -> - hash_preimage_of_updates ~cache t (Pnode p) um (function - | Node x -> a_of_hashable P.Node.Val.hash_exn x - | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) - | Map m -> - hash_preimage_of_map ~cache t m (function - | Node x -> a_of_hashable P.Node.Val.hash_exn x - | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) - - and hash_preimage_of_map : type r. - cache:bool -> t -> map -> (hash_preimage, r) cont = - fun ~cache t map k -> - cnt.node_val_v <- cnt.node_val_v + 1; - let bindings = StepMap.to_seq map in - let must_build_portable_node = - bindings - |> Seq.exists (fun (_, v) -> - match v with - | `Node n -> Option.is_none (cached_key n) - | `Contents (c, _) -> Option.is_none (Contents.cached_key c)) - in - if must_build_portable_node then - let pnode = - bindings - |> Seq.map (fun (step, v) -> - match v with - | `Contents (c, m) -> (step, `Contents (Contents.hash c, m)) - | `Node n -> hash ~cache n (fun k -> (step, `Node k))) - |> Portable.of_seq - in - k (Pnode pnode) - else - let node = - bindings - |> Seq.map (fun (step, v) -> - match v with - | `Contents (c, m) -> ( - match Contents.cached_key c with - | Some k -> (step, `Contents (k, m)) - | None -> - (* We checked that all child keys are cached above *) - assert false) - | `Node n -> ( - match cached_key n with - | Some k -> (step, `Node k) - | None -> - (* We checked that all child keys are cached above *) - assert false)) - |> P.Node.Val.of_seq - in - if cache then t.info.value <- Some node; - k (Node node) - - and hash_preimage_value_of_elt : type r. - cache:bool -> elt -> (hash_preimage_value, r) cont = - fun ~cache e k -> - match e with - | `Contents (c, m) -> ( - match Contents.key c with - | Some key -> k (Node_value (`Contents (key, m))) - | None -> k (Pnode_value (`Contents (Contents.hash c, m)))) - | `Node n -> ( - match key n with - | Some key -> k (Node_value (`Node key)) - | None -> hash ~cache n (fun hash -> k (Pnode_value (`Node hash)))) - - and hash_preimage_of_updates : type r. - cache:bool -> t -> hash_preimage -> updatemap -> (hash_preimage, r) cont - = - fun ~cache t v updates k -> - let updates = StepMap.bindings updates in - let rec aux acc = function - | [] -> - (if cache then - match acc with Node n -> t.info.value <- Some n | Pnode _ -> ()); - k acc - | (k, Add e) :: rest -> - hash_preimage_value_of_elt ~cache e (fun e -> - let acc = - match (acc, e) with - | Node n, Node_value v -> Node (P.Node.Val.add n k v) - | Node n, Pnode_value v -> - Pnode (Portable.add (Portable.of_node n) k v) - | Pnode n, Node_value v -> - Pnode (Portable.add n k (weaken_value v)) - | Pnode n, Pnode_value v -> Pnode (Portable.add n k v) - in - aux acc rest) - | (k, Remove) :: rest -> - let acc = - match acc with - | Node n -> Node (P.Node.Val.remove n k) - | Pnode n -> Pnode (Portable.remove n k) - in - aux acc rest - in - aux v updates - - let hash ~cache k = hash ~cache k (fun x -> x) - - let value_of_key ~cache t repo k = - match cached_value t with - | Some v -> ok v - | None -> ( - cnt.node_find <- cnt.node_find + 1; - let+ v_opt = P.Node.find (P.Repo.node_t repo) k in - let h = P.Node.Key.to_hash k in - let v_opt = Option.map (Env.add_node_from_store t.info.env h) v_opt in - match v_opt with - | None -> err_dangling_hash h - | Some v -> - if cache then t.info.value <- v_opt; - Ok v) - - let to_value ~cache t = - match - (Scan.cascade t [ Value; Repo_key; Any ] - : [ `value | `repo_key | `any ] Scan.t) - with - | Value v -> ok v - | Repo_key (repo, k) -> value_of_key ~cache t repo k - | Any -> ( - match t.v with - | Key _ | Value (_, _, None) -> assert false - | Pruned h -> err_pruned_hash h |> Lwt.return - | Portable_dirty _ -> err_portable_value |> Lwt.return - | Map _ | Value (_, _, Some _) -> - invalid_arg - "Tree.Node.to_value: the supplied node has not been written to \ - disk. Either export it or convert it to a portable value \ - instead.") - - let to_portable_value_aux ~cache ~value_of_key ~return ~bind:( let* ) t = - let ok x = return (Ok x) in - match - (Scan.cascade t - [ - Portable; Value; Repo_key; Portable_dirty; Value_dirty; Map; Pruned; - ] - : [ `portable - | `value - | `repo_key - | `portable_dirty - | `value_dirty - | `map - | `pruned ] - Scan.t) - with - | Portable p -> ok p - | Value v -> ok (P.Node_portable.of_node v) - | Portable_dirty (p, um) -> - hash_preimage_of_updates ~cache t (Pnode p) um (function - | Node _ -> assert false - | Pnode x -> ok x) - | Repo_key (repo, k) -> - let* value_res = value_of_key ~cache t repo k in - Result.map P.Node_portable.of_node value_res |> return - | Value_dirty (_repo, v, um) -> - hash_preimage_of_updates ~cache t (Node v) um (function - | Node x -> ok (Portable.of_node x) - | Pnode x -> ok x) - | Map m -> - hash_preimage_of_map ~cache t m (function - | Node x -> ok (Portable.of_node x) - | Pnode x -> ok x) - | Pruned h -> err_pruned_hash h |> return - - let to_portable_value = - to_portable_value_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind - - let to_map ~cache t = - let of_maps m updates = - let m = - match updates with - | None -> m - | Some updates -> - StepMap.stdlib_merge - (fun _ left right -> - match (left, right) with - | None, None -> assert false - | (Some _ as v), None -> v - | _, Some (Add v) -> Some v - | _, Some Remove -> None) - m updates - in - if cache then t.info.map <- Some m; - m - in - let of_value repo v um = - let env = t.info.env in - let m = Regular_value.to_map ~env ~cache repo v in - of_maps m um - in - let of_portable_value v um = - let env = t.info.env in - let m = Portable_value.to_map ~env ~cache () v in - of_maps m um - in - match - (Scan.cascade t - [ - Map; - Repo_value; - Repo_key; - Value_dirty; - Portable; - Portable_dirty; - Pruned; - ] - : [ `map - | `repo_key - | `repo_value - | `value_dirty - | `portable - | `portable_dirty - | `pruned ] - Scan.t) - with - | Map m -> ok m - | Repo_value (repo, v) -> ok (of_value repo v None) - | Repo_key (repo, k) -> ( - value_of_key ~cache t repo k >|= function - | Error _ as e -> e - | Ok v -> Ok (of_value repo v None)) - | Value_dirty (repo, v, um) -> ok (of_value repo v (Some um)) - | Portable p -> ok (of_portable_value p None) - | Portable_dirty (p, um) -> ok (of_portable_value p (Some um)) - | Pruned h -> err_pruned_hash h |> Lwt.return - - let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = - x1 == x2 || (Contents.equal c1 c2 && equal_metadata m1 m2) +(** Tree module types only. - let rec elt_equal (x : elt) (y : elt) = - x == y - || - match (x, y) with - | `Contents x, `Contents y -> contents_equal x y - | `Node x, `Node y -> equal x y - | _ -> false + 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]. *) - and map_equal (x : map) (y : map) = StepMap.equal elt_equal x y - - and equal (x : t) (y : t) = - x == y - || - match (cached_hash x, cached_hash y) with - | Some x, Some y -> equal_hash x y - | _ -> ( - match (cached_value x, cached_value y) with - | Some x, Some y -> equal_value x y - | _ -> ( - match (cached_portable x, cached_portable y) with - | Some x, Some y -> equal_portable x y - | _ -> ( - match (cached_map x, cached_map y) with - | Some x, Some y -> map_equal x y - | _ -> equal_hash (hash ~cache:true x) (hash ~cache:true y)))) - - (* same as [equal] but do not compare in-memory maps - recursively. *) - let maybe_equal (x : t) (y : t) = - if x == y then True - else - match (cached_hash x, cached_hash y) with - | Some x, Some y -> if equal_hash x y then True else False - | _ -> ( - match (cached_value x, cached_value y) with - | Some x, Some y -> if equal_value x y then True else False - | _ -> ( - match (cached_portable x, cached_portable y) with - | Some x, Some y -> if equal_portable x y then True else False - | _ -> Maybe)) - - let empty () = of_map StepMap.empty ~env:(Env.empty ()) - let empty_hash = hash ~cache:false (empty ()) - let singleton k v = of_map (StepMap.singleton k v) - - let slow_length ~cache t = - match - (Scan.cascade t - [ - Map; Value; Portable; Repo_key; Value_dirty; Portable_dirty; Pruned; - ] - : [ `map - | `value - | `portable - | `repo_key - | `value_dirty - | `portable_dirty - | `pruned ] - Scan.t) - with - | Map m -> StepMap.cardinal m |> Lwt.return - | Value v -> P.Node.Val.length v |> Lwt.return - | Portable p -> P.Node_portable.length p |> Lwt.return - | Repo_key (repo, k) -> - value_of_key ~cache t repo k >|= get_ok "length" >|= P.Node.Val.length - | Value_dirty (_repo, v, um) -> - hash_preimage_of_updates ~cache t (Node v) um (function - | Node x -> P.Node.Val.length x |> Lwt.return - | Pnode x -> P.Node_portable.length x |> Lwt.return) - | Portable_dirty (p, um) -> - hash_preimage_of_updates ~cache t (Pnode p) um (function - | Node _ -> assert false - | Pnode x -> P.Node_portable.length x |> Lwt.return) - | Pruned h -> pruned_hash_exn "length" h - - let length ~cache t = - match t.info.length with - | Some (lazy len) -> Lwt.return len - | None -> - let+ len = slow_length ~cache t in - t.info.length <- Some (Lazy.from_val len); - len - - let is_empty ~cache t = - match - (Scan.cascade t - [ Map; Value; Portable; Hash; Value_dirty; Portable_dirty ] - : [ `map - | `value - | `portable - | `hash - | `value_dirty - | `portable_dirty ] - Scan.t) - with - | Map m -> StepMap.is_empty m - | Value v -> P.Node.Val.is_empty v - | Portable p -> P.Node_portable.is_empty p - | Hash h -> equal_hash h empty_hash - | Value_dirty (_repo, v, um) -> - Regular_value.is_empty_after_updates ~cache v um - | Portable_dirty (p, um) -> - Portable_value.is_empty_after_updates ~cache p um - - let findv_aux ~cache ~value_of_key ~return ~bind:( let* ) ctx t step = - let of_map m = try Some (StepMap.find step m) with Not_found -> None in - let of_value = Regular_value.findv ~cache ~env:t.info.env step t in - let of_portable = Portable_value.findv ~cache ~env:t.info.env step t () in - let of_t () = - match - (Scan.cascade t - [ - Map; - Repo_value; - Repo_key; - Value_dirty; - Portable; - Portable_dirty; - Pruned; - ] - : [ `map - | `repo_key - | `repo_value - | `value_dirty - | `portable - | `portable_dirty - | `pruned ] - Scan.t) - with - | Map m -> return (of_map m) - | Repo_value (repo, v) -> return (of_value repo v) - | Repo_key (repo, k) -> - let* v = value_of_key ~cache t repo k in - let v = get_ok ctx v in - return (of_value repo v) - | Value_dirty (repo, v, um) -> ( - match StepMap.find_opt step um with - | Some (Add v) -> return (Some v) - | Some Remove -> return None - | None -> return (of_value repo v)) - | Portable p -> return (of_portable p) - | Portable_dirty (p, um) -> ( - match StepMap.find_opt step um with - | Some (Add v) -> return (Some v) - | Some Remove -> return None - | None -> return (of_portable p)) - | Pruned h -> pruned_hash_exn ctx h - in - match t.info.findv_cache with - | None -> of_t () - | Some m -> ( - match of_map m with None -> of_t () | Some _ as r -> return r) - - let findv = findv_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind - - let seq_of_map ?(offset = 0) ?length m : (step * elt) Seq.t = - let take seq = - match length with None -> seq | Some n -> Seq.take n seq - in - StepMap.to_seq m |> Seq.drop offset |> take - - let seq ?offset ?length ~cache t : (step * elt) Seq.t or_error Lwt.t = - let env = t.info.env in - match - (Scan.cascade t - [ - Map; - Repo_value; - Repo_key; - Value_dirty; - Portable; - Portable_dirty; - Pruned; - ] - : [ `map - | `repo_key - | `repo_value - | `value_dirty - | `portable - | `portable_dirty - | `pruned ] - Scan.t) - with - | Map m -> ok (seq_of_map ?offset ?length m) - | Repo_value (repo, v) -> - ok (Regular_value.seq ~env ?offset ?length ~cache repo v) - | Repo_key (repo, k) -> ( - value_of_key ~cache t repo k >>= function - | Error _ as e -> Lwt.return e - | Ok v -> ok (Regular_value.seq ~env ?offset ?length ~cache repo v)) - | Value_dirty _ | Portable_dirty _ -> ( - to_map ~cache t >>= function - | Error _ as e -> Lwt.return e - | Ok m -> ok (seq_of_map ?offset ?length m)) - | Portable p -> ok (Portable_value.seq ~env ?offset ?length ~cache () p) - | Pruned h -> err_pruned_hash h |> Lwt.return - - let bindings ~cache t = - (* XXX: If [t] is value, no need to [to_map]. Let's remove and inline - this into Tree.entries. *) - to_map ~cache t >|= function - | Error _ as e -> e - | Ok m -> Ok (StepMap.bindings m) - - let seq_of_updates updates value_bindings = - (* This operation can be costly for large updates. *) - if StepMap.is_empty updates then - (* Short-circuit return if we have no more updates to apply. *) - value_bindings - else - let value_bindings = - Seq.filter (fun (s, _) -> not (StepMap.mem s updates)) value_bindings - in - let updates = - StepMap.to_seq updates - |> Seq.filter_map (fun (s, elt) -> - match elt with Remove -> None | Add e -> Some (s, e)) - in - Seq.append value_bindings updates - - type ('v, 'acc, 'r) cps_folder = - path:Path.t -> 'acc -> int -> 'v -> ('acc, 'r) cont_lwt - (** A ('val, 'acc, 'r) cps_folder is a CPS, threaded fold function over - values of type ['v] producing an accumulator of type ['acc]. *) - - let fold : type acc. - order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> - force:acc force -> - cache:bool -> - uniq:uniq -> - pre:(acc, step list) folder option -> - post:(acc, step list) folder option -> - path:Path.t -> - ?depth:depth -> - node:(acc, _) folder -> - contents:(acc, contents) folder -> - tree:(acc, _) folder -> - t -> - acc -> - acc Lwt.t = - fun ~order ~force ~cache ~uniq ~pre ~post ~path ?depth ~node ~contents - ~tree t acc -> - let env = t.info.env in - let marks = - match uniq with - | `False -> dummy_marks - | `True -> empty_marks () - | `Marks n -> n - in - let pre path bindings acc = - match pre with - | None -> Lwt.return acc - | Some pre -> - let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in - pre path s acc - in - let post path bindings acc = - match post with - | None -> Lwt.return acc - | Some post -> - let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in - post path s acc - in - let rec aux : type r. (t, acc, r) cps_folder = - fun ~path acc d t k -> - let apply acc = node path t acc >>= tree path (`Node t) in - let next acc = - match force with - | `True -> ( - match order with - | `Random state -> - let* m = to_map ~cache t >|= get_ok "fold" in - let arr = StepMap.to_array m in - let () = shuffle state arr in - let s = Array.to_seq arr in - (seq [@tailcall]) ~path acc d s k - | `Sorted -> - let* m = to_map ~cache t >|= get_ok "fold" in - (map [@tailcall]) ~path acc d (Some m) k - | `Undefined -> ( - match - (Scan.cascade t - [ - Map; - Repo_value; - Repo_key; - Value_dirty; - Portable; - Portable_dirty; - Pruned; - ] - : [ `map - | `repo_key - | `repo_value - | `value_dirty - | `portable - | `portable_dirty - | `pruned ] - Scan.t) - with - | Map m -> (map [@tailcall]) ~path acc d (Some m) k - | Repo_value (repo, v) -> - (value [@tailcall]) ~path acc d (repo, v, None) k - | Repo_key (repo, _key) -> - let* v = to_value ~cache t >|= get_ok "fold" in - (value [@tailcall]) ~path acc d (repo, v, None) k - | Value_dirty (repo, v, um) -> - (value [@tailcall]) ~path acc d (repo, v, Some um) k - | Portable p -> (portable [@tailcall]) ~path acc d (p, None) k - | Portable_dirty (p, um) -> - (portable [@tailcall]) ~path acc d (p, Some um) k - | Pruned h -> pruned_hash_exn "fold" h)) - | `False skip -> ( - match cached_map t with - | Some n -> ( - match order with - | `Sorted | `Undefined -> - (map [@tailcall]) ~path acc d (Some n) k - | `Random state -> - let arr = StepMap.to_array n in - shuffle state arr; - let s = Array.to_seq arr in - (seq [@tailcall]) ~path acc d s k) - | None -> - (* XXX: That node is skipped if is is of tag Value *) - skip path acc >>= k) - in - match depth with - | None -> apply acc >>= next - | Some (`Eq depth) -> if d < depth then next acc else apply acc >>= k - | Some (`Le depth) -> - if d < depth then apply acc >>= next else apply acc >>= k - | Some (`Lt depth) -> - if d < depth - 1 then apply acc >>= next else apply acc >>= k - | Some (`Ge depth) -> if d < depth then next acc else apply acc >>= next - | Some (`Gt depth) -> - if d <= depth then next acc else apply acc >>= next - and aux_uniq : type r. (t, acc, r) cps_folder = - fun ~path acc d t k -> - if uniq = `False then (aux [@tailcall]) ~path acc d t k - else - let h = hash ~cache t in - match Hashes.add marks h with - | `Duplicate -> k acc - | `Ok -> (aux [@tailcall]) ~path acc d t k - and step : type r. (step * elt, acc, r) cps_folder = - fun ~path acc d (s, v) k -> - let path = Path.rcons path s in - match v with - | `Node n -> (aux_uniq [@tailcall]) ~path acc (d + 1) n k - | `Contents c -> ( - let apply () = - let tree path = tree path (`Contents c) in - Contents.fold ~force ~cache ~path contents tree (fst c) acc >>= k - in - match depth with - | None -> apply () - | Some (`Eq depth) -> if d = depth - 1 then apply () else k acc - | Some (`Le depth) -> if d < depth then apply () else k acc - | Some (`Lt depth) -> if d < depth - 1 then apply () else k acc - | Some (`Ge depth) -> if d >= depth - 1 then apply () else k acc - | Some (`Gt depth) -> if d >= depth then apply () else k acc) - and steps : type r. ((step * elt) Seq.t, acc, r) cps_folder = - fun ~path acc d s k -> - match s () with - | Seq.Nil -> k acc - | Seq.Cons (h, t) -> - (step [@tailcall]) ~path acc d h (fun acc -> - (steps [@tailcall]) ~path acc d t k) - and map : type r. (map option, acc, r) cps_folder = - fun ~path acc d m k -> - match m with - | None -> k acc - | Some m -> - let bindings = StepMap.to_seq m in - seq ~path acc d bindings k - and value : type r. (repo * value * updatemap option, acc, r) cps_folder = - fun ~path acc d (repo, v, updates) k -> - let bindings = Regular_value.seq ~env ~cache repo v in - let bindings = - match updates with - | None -> bindings - | Some updates -> seq_of_updates updates bindings - in - seq ~path acc d bindings k - and portable : type r. (portable * updatemap option, acc, r) cps_folder = - fun ~path acc d (v, updates) k -> - let bindings = Portable_value.seq ~env ~cache () v in - let bindings = - match updates with - | None -> bindings - | Some updates -> seq_of_updates updates bindings - in - seq ~path acc d bindings k - and seq : type r. ((step * elt) Seq.t, acc, r) cps_folder = - fun ~path acc d bindings k -> - let* acc = pre path bindings acc in - (steps [@tailcall]) ~path acc d bindings (fun acc -> - post path bindings acc >>= k) - in - aux_uniq ~path acc 0 t Lwt.return - - let incremental_length t step up n updates = - match t.info.length with - | None -> None - | Some len -> - Some - (lazy - (let len = Lazy.force len in - let exists = - match StepMap.find_opt step updates with - | Some (Add _) -> true - | Some Remove -> false - | None -> ( - match P.Node.Val.find n step with - | None -> false - | Some _ -> true) - in - match up with - | Add _ when not exists -> len + 1 - | Remove when exists -> len - 1 - | _ -> len)) - - let update t step up = - let env = t.info.env in - let of_map m = - let m' = - match up with - | Remove -> StepMap.remove step m - | Add v -> StepMap.add step v m - in - if m == m' then t else of_map ~env m' - in - let of_value repo n updates = - let updates' = StepMap.add step up updates in - if updates == updates' then t - else - let length = incremental_length t step up n updates in - of_value ?length ~env repo n ~updates:updates' - in - let of_portable n updates = - let updates' = StepMap.add step up updates in - if updates == updates' then t else of_portable_dirty ~env n updates' - in - match - (Scan.cascade t - [ - Map; - Repo_value; - Repo_key; - Value_dirty; - Portable; - Portable_dirty; - Pruned; - ] - : [ `map - | `repo_key - | `repo_value - | `value_dirty - | `portable - | `portable_dirty - | `pruned ] - Scan.t) - with - | Map m -> Lwt.return (of_map m) - | Repo_value (repo, v) -> Lwt.return (of_value repo v StepMap.empty) - | Repo_key (repo, k) -> - let+ v = value_of_key ~cache:true t repo k >|= get_ok "update" in - of_value repo v StepMap.empty - | Value_dirty (repo, v, um) -> Lwt.return (of_value repo v um) - | Portable p -> Lwt.return (of_portable p StepMap.empty) - | Portable_dirty (p, um) -> Lwt.return (of_portable p um) - | Pruned h -> pruned_hash_exn "update" h - - let remove t step = update t step Remove - let add t step v = update t step (Add v) - - let compare (x : t) (y : t) = - if x == y then 0 - else compare_hash (hash ~cache:true x) (hash ~cache:true y) - - let t node = - let of_v v = of_v ~env:(Env.empty ()) v in - Type.map ~equal ~compare node of_v (fun t -> t.v) - - let _, t = - Type.mu2 (fun _ y -> - let elt = elt_t y in - let v = v_t elt in - let t = t v in - (v, t)) - - let elt_t = elt_t t - let dump = Type.pp_dump t - - let rec merge : type a. (t Merge.t -> a) -> a = - fun k -> - let f ~old x y = - let old = - Merge.bind_promise old (fun old () -> - let+ m = to_map ~cache:true old >|= Option.of_result in - Ok (Some m)) - in - match merge_env x.info.env y.info.env with - | Error _ as e -> Lwt.return e - | Ok env -> ( - let* x = to_map ~cache:true x >|= Option.of_result in - let* y = to_map ~cache:true y >|= Option.of_result in - let m = - StepMap.merge elt_t (fun _step -> - (merge_elt [@tailcall]) Merge.option) - in - Merge.(f @@ option m) ~old x y >|= function - | Ok (Some map) -> Ok (of_map ~env map) - | Ok None -> Error (`Conflict "empty map") - | Error _ as e -> e) - in - k (Merge.v t f) - - and merge_elt : type r. (elt Merge.t, r) cont = - fun k -> - let open Merge.Infix in - let f : elt Merge.f = - fun ~old x y -> - match (x, y) with - | `Contents (x, cx), `Contents (y, cy) -> - let mold = - Merge.bind_promise old (fun old () -> - match old with - | `Contents (_, m) -> ok (Some m) - | `Node _ -> ok None) - in - Merge.(f Metadata.merge) ~old:mold cx cy >>=* fun m -> - let old = - Merge.bind_promise old (fun old () -> - match old with - | `Contents (c, _) -> ok (Some c) - | `Node _ -> ok None) - in - Merge.(f Contents.merge) ~old x y >>=* fun c -> - Merge.ok (`Contents (c, m)) - | `Node x, `Node y -> - (merge [@tailcall]) (fun m -> - let old = - Merge.bind_promise old (fun old () -> - match old with - | `Contents _ -> ok None - | `Node n -> ok (Some n)) - in - Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n)) - | _ -> Merge.conflict "add/add values" - in - k (Merge.seq [ Merge.default elt_t; Merge.v elt_t f ]) - - let merge_elt = merge_elt (fun x -> x) - end - - type node = Node.t [@@deriving irmin ~pp] - type node_key = Node.key [@@deriving irmin ~pp] - type contents_key = Contents.key [@@deriving irmin ~pp] - - type kinded_key = [ `Contents of Contents.key * metadata | `Node of Node.key ] - [@@deriving irmin] - - type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] - [@@deriving irmin ~equal] - - type t = [ `Node of node | `Contents of Contents.t * Metadata.t ] - [@@deriving irmin] - - let to_backend_node n = - Node.to_value ~cache:true n >|= get_ok "to_backend_node" - - let to_backend_portable_node n = - Node.to_portable_value ~cache:true n >|= get_ok "to_backend_portable_node" - - let of_backend_node repo n = - let env = Env.empty () in - let length = lazy (P.Node.Val.length n) in - Node.of_value ~length ~env repo n - - let dump ppf = function - | `Node n -> Fmt.pf ppf "node: %a" Node.dump n - | `Contents (c, _) -> Fmt.pf ppf "contents: %a" (Type.pp Contents.t) c - - let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = - x1 == x2 - || (c1 == c2 && m1 == m2) - || (Contents.equal c1 c2 && equal_metadata m1 m2) - - let equal (x : t) (y : t) = - x == y - || - match (x, y) with - | `Node x, `Node y -> Node.equal x y - | `Contents x, `Contents y -> contents_equal x y - | `Node _, `Contents _ | `Contents _, `Node _ -> false - - let is_empty = function - | `Node n -> Node.is_empty ~cache:true n - | `Contents _ -> false - - type elt = [ `Node of node | `Contents of contents * metadata ] - - let of_node n = `Node n - - let of_contents ?(metadata = Metadata.default) c = - let env = Env.empty () in - let c = Contents.of_value ~env c in - `Contents (c, metadata) - - let v : elt -> t = function - | `Contents (c, metadata) -> of_contents ~metadata c - | `Node n -> `Node n - - let pruned_with_env ~env = function - | `Contents (h, meta) -> `Contents (Contents.pruned ~env h, meta) - | `Node h -> `Node (Node.pruned ~env h) - - let pruned h = - let env = Env.empty () in - pruned_with_env ~env h - - let destruct x = x - - let clear ?(depth = 0) = function - | `Node n -> Node.clear ~max_depth:depth 0 n - | `Contents _ -> () - - let sub ~cache ctx t path = - let rec aux node path = - match Path.decons path with - | None -> Lwt.return_some node - | Some (h, p) -> ( - Node.findv ~cache ctx node h >>= function - | None | Some (`Contents _) -> Lwt.return_none - | Some (`Node n) -> (aux [@tailcall]) n p) - in - match t with - | `Node n -> (aux [@tailcall]) n path - | `Contents _ -> Lwt.return_none - - let find_tree (t : t) path = - let cache = true in - [%log.debug "Tree.find_tree %a" pp_path path]; - match (t, Path.rdecons path) with - | v, None -> Lwt.return_some v - | _, Some (path, file) -> ( - sub ~cache "find_tree.sub" t path >>= function - | None -> Lwt.return_none - | Some n -> Node.findv ~cache "find_tree.findv" n file) - - let id _ _ acc = Lwt.return acc - - let fold ?(order = `Sorted) ?(force = `True) ?(cache = false) ?(uniq = `False) - ?pre ?post ?depth ?(contents = id) ?(node = id) ?(tree = id) (t : t) acc = - match t with - | `Contents (c, _) as c' -> - let tree path = tree path c' in - Contents.fold ~force ~cache ~path:Path.empty contents tree c acc - | `Node n -> - Node.fold ~order ~force ~cache ~uniq ~pre ~post ~path:Path.empty ?depth - ~contents ~node ~tree n acc - - type stats = { - nodes : int; - leafs : int; - skips : int; - depth : int; - width : int; - } - [@@deriving irmin] - - let empty_stats = { nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } - let incr_nodes s = { s with nodes = s.nodes + 1 } - let incr_leafs s = { s with leafs = s.leafs + 1 } - let incr_skips s = { s with skips = s.skips + 1 } - - let set_depth p s = - let n_depth = List.length (Path.map p (fun _ -> ())) in - let depth = max n_depth s.depth in - { s with depth } - - let set_width childs s = - let width = max s.width (List.length childs) in - { s with width } - - let err_not_found n k = - Fmt.kstr invalid_arg "Irmin.Tree.%s: %a not found" n pp_path k - - let get_tree (t : t) path = - find_tree t path >|= function - | None -> err_not_found "get_tree" path - | Some v -> v - - let find_all t k = - find_tree t k >>= function - | None | Some (`Node _) -> Lwt.return_none - | Some (`Contents (c, m)) -> - let+ c = Contents.to_value ~cache:true c in - Some (get_ok "find_all" c, m) - - let find t k = - find_all t k >|= function None -> None | Some (c, _) -> Some c - - let get_all t k = - find_all t k >>= function - | None -> err_not_found "get" k - | Some v -> Lwt.return v - - let get t k = get_all t k >|= fun (c, _) -> c - let mem t k = find t k >|= function None -> false | _ -> true - let mem_tree t k = find_tree t k >|= function None -> false | _ -> true - - let kind t path = - let cache = true in - [%log.debug "Tree.kind %a" pp_path path]; - match (t, Path.rdecons path) with - | `Contents _, None -> Lwt.return_some `Contents - | `Node _, None -> Lwt.return_some `Node - | _, Some (dir, file) -> ( - sub ~cache "kind.sub" t dir >>= function - | None -> Lwt.return_none - | Some m -> ( - Node.findv ~cache "kind.findv" m file >>= function - | None -> Lwt.return_none - | Some (`Contents _) -> Lwt.return_some `Contents - | Some (`Node _) -> Lwt.return_some `Node)) - - let length t ?(cache = true) path = - [%log.debug "Tree.length %a" pp_path path]; - sub ~cache "length" t path >>= function - | None -> Lwt.return 0 - | Some n -> Node.length ~cache:true n - - let seq t ?offset ?length ?(cache = true) path = - [%log.debug "Tree.seq %a" pp_path path]; - sub ~cache "seq.sub" t path >>= function - | None -> Lwt.return Seq.empty - | Some n -> Node.seq ?offset ?length ~cache n >|= get_ok "seq" - - let list t ?offset ?length ?(cache = true) path = - seq t ?offset ?length ~cache path >|= List.of_seq - - let empty () = `Node (Node.empty ()) - - let singleton k ?(metadata = Metadata.default) c = - [%log.debug "Tree.singleton %a" pp_path k]; - let env = Env.empty () in - let base_tree = `Contents (Contents.of_value ~env c, metadata) in - Path.fold_right k - ~f:(fun step child -> `Node (Node.singleton ~env step child)) - ~init:base_tree - - (** During recursive updates, we keep track of whether or not we've made a - modification in order to avoid unnecessary allocations of identical tree - objects. *) - type 'a updated = Changed of 'a | Unchanged - - let maybe_equal (x : t) (y : t) = - if x == y then True - else - match (x, y) with - | `Node x, `Node y -> Node.maybe_equal x y - | _ -> if equal x y then True else False - - let get_env = function - | `Node n -> n.Node.info.env - | `Contents (c, _) -> c.Contents.info.env - - let update_tree ~cache ~f_might_return_empty_node ~f root_tree path = - (* User-introduced empty nodes will be removed immediately if necessary. *) - let prune_empty : node -> bool = - if not f_might_return_empty_node then Fun.const false - else Node.is_empty ~cache - in - match Path.rdecons path with - | None -> ( - let empty_tree = - match is_empty root_tree with - | true -> root_tree - | false -> `Node (Node.empty ()) - in - f (Some root_tree) >>= function - (* Here we consider "deleting" a root contents value or node to consist - of changing it to an empty node. Note that this introduces - sensitivity to ordering of subtree operations: updating in a subtree - and adding the subtree are not necessarily commutative. *) - | None -> Lwt.return empty_tree - | Some (`Node _ as new_root) -> ( - match maybe_equal root_tree new_root with - | True -> Lwt.return root_tree - | Maybe | False -> Lwt.return new_root) - | Some (`Contents c' as new_root) -> ( - match root_tree with - | `Contents c when contents_equal c c' -> Lwt.return root_tree - | _ -> Lwt.return new_root)) - | Some (path, file) -> ( - let rec aux : type r. path -> node -> (node updated, r) cont_lwt = - fun path parent_node k -> - let changed n = k (Changed n) in - match Path.decons path with - | None -> ( - let with_new_child t = Node.add parent_node file t >>= changed in - let* old_binding = - Node.findv ~cache "update_tree.findv" parent_node file - in - let* new_binding = f old_binding in - match (old_binding, new_binding) with - | None, None -> k Unchanged - | None, Some (`Contents _ as t) -> with_new_child t - | None, Some (`Node n as t) -> ( - match prune_empty n with - | true -> k Unchanged - | false -> with_new_child t) - | Some _, None -> Node.remove parent_node file >>= changed - | Some old_value, Some (`Node n as t) -> ( - match prune_empty n with - | true -> Node.remove parent_node file >>= changed - | false -> ( - match maybe_equal old_value t with - | True -> k Unchanged - | Maybe | False -> with_new_child t)) - | Some (`Contents c), Some (`Contents c' as t) -> ( - match contents_equal c c' with - | true -> k Unchanged - | false -> with_new_child t) - | Some (`Node _), Some (`Contents _ as t) -> with_new_child t) - | Some (step, key_suffix) -> - let* old_binding = - Node.findv ~cache "update_tree.findv" parent_node step - in - let to_recurse = - match old_binding with - | Some (`Node child) -> child - | None | Some (`Contents _) -> Node.empty () - in - (aux [@tailcall]) key_suffix to_recurse (function - | Unchanged -> - (* This includes [remove]s in an empty node, in which case we - want to avoid adding a binding anyway. *) - k Unchanged - | Changed child -> ( - match Node.is_empty ~cache child with - | true -> - (* A [remove] has emptied previously non-empty child with - binding [h], so we remove the binding. *) - Node.remove parent_node step >>= changed - | false -> - Node.add parent_node step (`Node child) >>= changed)) - in - let top_node = - match root_tree with `Node n -> n | `Contents _ -> Node.empty () - in - aux path top_node @@ function - | Unchanged -> Lwt.return root_tree - | Changed node -> - Env.copy ~into:node.info.env (get_env root_tree); - Lwt.return (`Node node)) - - let update t k ?(metadata = Metadata.default) f = - let cache = true in - [%log.debug "Tree.update %a" pp_path k]; - update_tree ~cache t k ~f_might_return_empty_node:false ~f:(fun t -> - let+ old_contents = - match t with - | Some (`Node _) | None -> Lwt.return_none - | Some (`Contents (c, _)) -> - let+ c = Contents.to_value ~cache c in - Some (get_ok "update" c) - in - match f old_contents with - | None -> None - | Some c -> of_contents ~metadata c |> Option.some) - - let add t k ?(metadata = Metadata.default) c = - [%log.debug "Tree.add %a" pp_path k]; - update_tree ~cache:true t k - ~f:(fun _ -> Lwt.return_some (of_contents ~metadata c)) - ~f_might_return_empty_node:false - - let add_tree t k v = - [%log.debug "Tree.add_tree %a" pp_path k]; - update_tree ~cache:true t k - ~f:(fun _ -> Lwt.return_some v) - ~f_might_return_empty_node:true - - let remove t k = - [%log.debug "Tree.remove %a" pp_path k]; - update_tree ~cache:true t k - ~f:(fun _ -> Lwt.return_none) - ~f_might_return_empty_node:false - - let update_tree t k f = - [%log.debug "Tree.update_tree %a" pp_path k]; - update_tree ~cache:true t k ~f:(Lwt.wrap1 f) ~f_might_return_empty_node:true - - let import repo = function - | `Contents (k, m) -> ( - cnt.contents_mem <- cnt.contents_mem + 1; - P.Contents.mem (P.Repo.contents_t repo) k >|= function - | true -> - let env = Env.empty () in - Some (`Contents (Contents.of_key ~env repo k, m)) - | false -> None) - | `Node k -> ( - cnt.node_mem <- cnt.node_mem + 1; - P.Node.mem (P.Repo.node_t repo) k >|= function - | true -> - let env = Env.empty () in - Some (`Node (Node.of_key ~env repo k)) - | false -> None) - - let import_with_env ~env repo = function - | `Node k -> `Node (Node.of_key ~env repo k) - | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) - - let import_no_check repo f = - let env = Env.empty () in - import_with_env ~env repo f - - let same_repo r1 r2 = - r1 == r2 || Conf.equal (P.Repo.config r1) (P.Repo.config r2) - - (* Given an arbitrary tree value, persist its contents to the given contents - and node stores via a depth-first {i post-order} traversal. We must export - a node's children before the node itself in order to get the {i keys} of - any un-persisted child values. *) - let export ?clear repo contents_t node_t n = - [%log.debug "Tree.export clear=%a" Fmt.(option bool) clear]; - let cache = - match clear with - | Some true | None -> - (* This choice of [cache] flag has no impact, since we either - immediately clear the corresponding cache or are certain that - the it is already filled. *) - false - | Some false -> true - in - - let add_node n v k = - cnt.node_add <- cnt.node_add + 1; - let* key = P.Node.add node_t v in - let () = - (* Sanity check: Did we just store the same hash as the one represented - by the Tree.Node [n]? *) - match Node.cached_hash n with - | None -> - (* No hash is in [n]. Computing it would result in getting it from - [v] or rebuilding a private node. *) - () - | Some h' -> - let h = P.Node.Key.to_hash key in - if not (equal_hash h h') then - backend_invariant_violation - "@[Tree.export: added inconsistent node binding@,\ - key: %a@,\ - value: %a@,\ - computed hash: %a@]" - pp_node_key key Node.pp_value v pp_hash h' - in - k key - in - - let add_node_map n (x : Node.map) k = - let node = - (* Since we traverse in post-order, all children of [x] have already - been added. Thus, their keys are cached and we can retrieve them. *) - cnt.node_val_v <- cnt.node_val_v + 1; - StepMap.to_seq x - |> Seq.map (fun (step, v) -> - match v with - | `Node n -> ( - match Node.cached_key n with - | Some k -> (step, `Node k) - | None -> - assertion_failure - "Encountered child node value with uncached key during \ - export:@,\ - @ @[%a@]" - dump v) - | `Contents (c, m) -> ( - match Contents.cached_key c with - | Some k -> (step, `Contents (k, m)) - | None -> - assertion_failure - "Encountered child contents value with uncached key \ - during export:@,\ - @ @[%a@]" - dump v)) - |> P.Node.Val.of_seq - in - add_node n node k - in - - let add_updated_node n (v : Node.value) (updates : Node.updatemap) k = - let node = - StepMap.fold - (fun k v acc -> - match v with - | Node.Remove -> P.Node.Val.remove acc k - | Node.Add (`Node n as v) -> ( - match Node.cached_key n with - | Some ptr -> P.Node.Val.add acc k (`Node ptr) - | None -> - assertion_failure - "Encountered child node value with uncached key during \ - export:@,\ - @ @[%a@]" - dump v) - | Add (`Contents (c, m) as v) -> ( - match Contents.cached_key c with - | Some ptr -> P.Node.Val.add acc k (`Contents (ptr, m)) - | None -> - assertion_failure - "Encountered child contents value with uncached key \ - during export:@,\ - @ @[%a@]" - dump v)) - updates v - in - add_node n node k - in - - let rec on_node : type r. [ `Node of node ] -> (node_key, r) cont_lwt = - fun (`Node n) k -> - let k key = - (* All the nodes in the exported tree should be cleaned using - [Node.export]. This ensures that [key] is stored in [n]. *) - Node.export ?clear repo n key; - k key - in - let has_repo = - match n.Node.v with - | Node.Key (repo', _) -> - if same_repo repo repo' then true - else - (* Case 1. [n] is a key from another repo. Let's crash. - - We could also only crash if the hash in the key is unknown to - [repo], or completely ignore the issue. *) - failwith "Can't export the node key from another repo" - | Value (repo', _, _) -> - if same_repo repo repo' then true - else - (* Case 2. [n] is a value from another repo. Let's crash. - - We could also ignore the issue. *) - failwith "Can't export a node value from another repo" - | Pruned _ | Portable_dirty _ | Map _ -> false - in - match n.Node.v with - | Pruned h -> - (* Case 3. [n] is a pruned hash. [P.Node.index node_t h] could be - different than [None], but let's always crash. *) - pruned_hash_exn "export" h - | Portable_dirty _ -> - (* Case 4. [n] is a portable value with diffs. The hash of the - reconstructed portable value could be known by [repo], but let's - always crash. *) - portable_value_exn "export" - | Map _ | Value _ | Key _ -> ( - match Node.cached_key n with - | Some key -> - if has_repo then - (* Case 5. [n] is a key that is accompanied by the [repo]. Let's - assume that [P.Node.mem node_t key] is [true] for performance - reason (not benched). *) - k key - else ( - cnt.node_mem <- cnt.node_mem + 1; - let* mem = P.Node.mem node_t key in - if not mem then - (* Case 6. [n] contains a key that is not known by [repo]. - Let's abort. *) - failwith "Can't export a key unkown from the repo" - else - (* Case 7. [n] contains a key that is known by the [repo]. *) - k key) - | None -> ( - let* skip_when_some = - match Node.cached_hash n with - | None -> - (* No pre-computed hash. *) - Lwt.return_none - | Some h -> ( - cnt.node_index <- cnt.node_index + 1; - P.Node.index node_t h >>= function - | None -> - (* Pre-computed hash is unknown by repo. - - NOTE: it's possible that this value already has a key - in the store, but it's not indexed. If so, we're - adding a duplicate here – this isn't an issue for - correctness, but does waste space. *) - Lwt.return_none - | Some key -> - cnt.node_mem <- cnt.node_mem + 1; - let+ mem = P.Node.mem node_t key in - if mem then - (* Case 8. The pre-computed hash is converted into - a key *) - Some key - else - (* The backend could produce a key from [h] but - doesn't know [h]. *) - None) - in - match skip_when_some with - | Some key -> k key - | None -> ( - (* Only [Map _ | Value _] possible now. - - Case 9. Let's export it to the backend. *) - let new_children_seq = - let seq = - match n.Node.v with - | Value (_, _, Some m) -> - StepMap.to_seq m - |> Seq.filter_map (function - | step, Node.Add v -> Some (step, v) - | _, Remove -> None) - | Map m -> StepMap.to_seq m - | Value (_, _, None) -> Seq.empty - | Key _ | Portable_dirty _ | Pruned _ -> - (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is - excluded above. *) - assert false - in - Seq.map (fun (_, x) -> x) seq - in - on_node_seq new_children_seq @@ fun `Node_children_exported -> - match (n.Node.v, Node.cached_value n) with - | Map x, _ -> add_node_map n x k - | Value (_, v, None), None | _, Some v -> add_node n v k - | Value (_, v, Some um), _ -> add_updated_node n v um k - | (Key _ | Portable_dirty _ | Pruned _), _ -> - (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is - excluded above. *) - assert false))) - and on_contents : type r. - [ `Contents of Contents.t * metadata ] -> - ([ `Content_exported ], r) cont_lwt = - fun (`Contents (c, _)) k -> - match c.Contents.v with - | Contents.Key (_, key) -> - Contents.export ?clear repo c key; - k `Content_exported - | Contents.Value _ -> - let* v = Contents.to_value ~cache c in - let v = get_ok "export" v in - cnt.contents_add <- cnt.contents_add + 1; - let* key = P.Contents.add contents_t v in - let () = - let h = P.Contents.Key.to_hash key in - let h' = Contents.hash ~cache c in - if not (equal_hash h h') then - backend_invariant_violation - "@[Tree.export: added inconsistent contents binding@,\ - key: %a@,\ - value: %a@,\ - computed hash: %a@]" - pp_contents_key key pp_contents v pp_hash h' - in - Contents.export ?clear repo c key; - k `Content_exported - | Contents.Pruned h -> pruned_hash_exn "export" h - and on_node_seq : type r. - Node.elt Seq.t -> ([ `Node_children_exported ], r) cont_lwt = - fun seq k -> - match seq () with - | Seq.Nil -> - (* Have iterated on all children, let's export parent now *) - k `Node_children_exported - | Seq.Cons ((`Node _ as n), rest) -> - on_node n (fun _node_key -> on_node_seq rest k) - | Seq.Cons ((`Contents _ as c), rest) -> - on_contents c (fun `Content_exported -> on_node_seq rest k) - in - on_node (`Node n) (fun key -> Lwt.return key) - - let merge : t Merge.t = - let f ~old (x : t) y = - Merge.(f Node.merge_elt) ~old x y >>= function - | Ok t -> Merge.ok t - | Error e -> Lwt.return (Error e) - in - Merge.v t f - - let entries path tree = - let rec aux acc = function - | [] -> Lwt.return acc - | (path, h) :: todo -> - let* childs = Node.bindings ~cache:true h >|= get_ok "entries" in - let acc, todo = - List.fold_left - (fun (acc, todo) (k, v) -> - let path = Path.rcons path k in - match v with - | `Node v -> (acc, (path, v) :: todo) - | `Contents c -> ((path, c) :: acc, todo)) - (acc, todo) childs - in - (aux [@tailcall]) acc todo - in - (aux [@tailcall]) [] [ (path, tree) ] - - (** Given two forced lazy values, return an empty diff if they both use the - same dangling hash. *) - let diff_force_result (type a b) ~(empty : b) ~(diff_ok : a * a -> b) - (x : a or_error) (y : a or_error) : b = - match (x, y) with - | ( Error (`Dangling_hash h1 | `Pruned_hash h1), - Error (`Dangling_hash h2 | `Pruned_hash h2) ) -> ( - match equal_hash h1 h2 with true -> empty | false -> assert false) - | Error _, Ok _ -> assert false - | Ok _, Error _ -> assert false - | Ok x, Ok y -> diff_ok (x, y) - | Error _, Error _ -> assert false - - let diff_contents x y = - if Node.contents_equal x y then Lwt.return_nil - else - let* cx = Contents.to_value ~cache:true (fst x) in - let+ cy = Contents.to_value ~cache:true (fst y) in - diff_force_result cx cy ~empty:[] ~diff_ok:(fun (cx, cy) -> - [ `Updated ((cx, snd x), (cy, snd y)) ]) - - let diff_node (x : node) (y : node) = - let bindings n = - Node.to_map ~cache:true n >|= function - | Ok m -> Ok (StepMap.bindings m) - | Error _ as e -> e - in - let removed acc (k, (c, m)) = - let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in - (k, `Removed (c, m)) :: acc - in - let added acc (k, (c, m)) = - let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in - (k, `Added (c, m)) :: acc - in - let rec diff_bindings acc todo path x y = - let acc = ref acc in - let todo = ref todo in - let* () = - alist_iter2_lwt compare_step - (fun key v -> - let path = Path.rcons path key in - match v with - (* Left *) - | `Left (`Contents x) -> - let+ x = removed !acc (path, x) in - acc := x - | `Left (`Node x) -> - let* xs = entries path x in - let+ xs = Lwt_list.fold_left_s removed !acc xs in - acc := xs - (* Right *) - | `Right (`Contents y) -> - let+ y = added !acc (path, y) in - acc := y - | `Right (`Node y) -> - let* ys = entries path y in - let+ ys = Lwt_list.fold_left_s added !acc ys in - acc := ys - (* Both *) - | `Both (`Node x, `Node y) -> - todo := (path, x, y) :: !todo; - Lwt.return_unit - | `Both (`Contents x, `Node y) -> - let* ys = entries path y in - let* x = removed !acc (path, x) in - let+ ys = Lwt_list.fold_left_s added x ys in - acc := ys - | `Both (`Node x, `Contents y) -> - let* xs = entries path x in - let* y = added !acc (path, y) in - let+ ys = Lwt_list.fold_left_s removed y xs in - acc := ys - | `Both (`Contents x, `Contents y) -> - let+ content_diffs = - diff_contents x y >|= List.map (fun d -> (path, d)) - in - acc := content_diffs @ !acc) - x y - in - (diff_node [@tailcall]) !acc !todo - and diff_node acc = function - | [] -> Lwt.return acc - | (path, x, y) :: todo -> - if Node.equal x y then (diff_node [@tailcall]) acc todo - else - let* x = bindings x in - let* y = bindings y in - diff_force_result ~empty:Lwt.return_nil - ~diff_ok:(fun (x, y) -> diff_bindings acc todo path x y) - x y - in - (diff_node [@tailcall]) [] [ (Path.empty, x, y) ] - - let diff (x : t) (y : t) = - match (x, y) with - | `Contents ((c1, m1) as x), `Contents ((c2, m2) as y) -> - if contents_equal x y then Lwt.return_nil - else - let* c1 = Contents.to_value ~cache:true c1 >|= get_ok "diff" in - let* c2 = Contents.to_value ~cache:true c2 >|= get_ok "diff" in - Lwt.return [ (Path.empty, `Updated ((c1, m1), (c2, m2))) ] - | `Node x, `Node y -> diff_node x y - | `Contents (x, m), `Node y -> - let* diff = diff_node (Node.empty ()) y in - let+ x = Contents.to_value ~cache:true x >|= get_ok "diff" in - (Path.empty, `Removed (x, m)) :: diff - | `Node x, `Contents (y, m) -> - let* diff = diff_node x (Node.empty ()) in - let+ y = Contents.to_value ~cache:true y >|= get_ok "diff" in - (Path.empty, `Added (y, m)) :: diff - - type concrete = - [ `Tree of (Path.step * concrete) list - | `Contents of P.Contents.Val.t * Metadata.t ] - [@@deriving irmin] - - type 'a or_empty = Empty | Non_empty of 'a - - let of_concrete c = - let rec concrete : type r. concrete -> (t or_empty, r) cont = - fun t k -> - match t with - | `Contents (c, m) -> k (Non_empty (of_contents ~metadata:m c)) - | `Tree childs -> - tree StepMap.empty childs (function - | Empty -> k Empty - | Non_empty n -> k (Non_empty (`Node n))) - and tree : type r. - Node.elt StepMap.t -> (step * concrete) list -> (node or_empty, r) cont - = - fun map t k -> - match t with - | [] -> - k - (if StepMap.is_empty map then Empty - else Non_empty (Node.of_map ~env:(Env.empty ()) map)) - | (s, n) :: t -> - (concrete [@tailcall]) n (fun v -> - (tree [@tailcall]) - (StepMap.update s - (function - | None -> ( - match v with - | Empty -> None (* Discard empty sub-directories *) - | Non_empty v -> Some v) - | Some _ -> - Fmt.invalid_arg - "of_concrete: duplicate bindings for step `%a`" - pp_step s) - map) - t k) - in - (concrete [@tailcall]) c (function Empty -> empty () | Non_empty x -> x) - - let to_concrete t = - let rec tree : type r. t -> (concrete, r) cont_lwt = - fun t k -> - match t with - | `Contents c -> contents c k - | `Node n -> - let* m = Node.to_map ~cache:true n in - let bindings = m |> get_ok "to_concrete" |> StepMap.bindings in - (node [@tailcall]) [] bindings (fun n -> - let n = List.sort (fun (s, _) (s', _) -> compare_step s s') n in - k (`Tree n)) - and contents : type r. Contents.t * metadata -> (concrete, r) cont_lwt = - fun (c, m) k -> - let* c = Contents.to_value ~cache:true c >|= get_ok "to_concrete" in - k (`Contents (c, m)) - and node : type r. - (step * concrete) list -> - (step * Node.elt) list -> - ((step * concrete) list, r) cont_lwt = - fun childs x k -> - match x with - | [] -> k childs - | (s, n) :: t -> ( - match n with - | `Node _ as n -> - (tree [@tailcall]) n (fun tree -> node ((s, tree) :: childs) t k) - | `Contents c -> - (contents [@tailcall]) c (fun c -> - (node [@tailcall]) ((s, c) :: childs) t k)) - in - tree t (fun x -> Lwt.return x) - - let key (t : t) = - [%log.debug "Tree.key"]; - match t with - | `Node n -> ( - match Node.key n with Some key -> Some (`Node key) | None -> None) - | `Contents (c, m) -> ( - match Contents.key c with - | Some key -> Some (`Contents (key, m)) - | None -> None) - - let hash ?(cache = true) (t : t) = - [%log.debug "Tree.hash"]; - match t with - | `Node n -> `Node (Node.hash ~cache n) - | `Contents (c, m) -> `Contents (Contents.hash ~cache c, m) - - let stats ?(force = false) (t : t) = - let cache = true in - let force = - if force then `True - else `False (fun k s -> set_depth k s |> incr_skips |> Lwt.return) - in - let contents k _ s = set_depth k s |> incr_leafs |> Lwt.return in - let pre k childs s = - if childs = [] then Lwt.return s - else set_depth k s |> set_width childs |> incr_nodes |> Lwt.return - in - let post _ _ acc = Lwt.return acc in - fold ~force ~cache ~pre ~post ~contents t empty_stats - - let counters () = cnt - let dump_counters ppf () = dump_counters ppf cnt - let reset_counters () = reset_counters cnt - - let inspect = function - | `Contents _ -> `Contents - | `Node n -> - `Node - (match n.Node.v with - | Map _ -> `Map - | Value _ -> `Value - | Key _ -> `Key - | Portable_dirty _ -> `Portable_dirty - | Pruned _ -> `Pruned) - - module Proof = struct - type irmin_tree = t - - include Tree_proof - - type proof_tree = tree - type proof_inode = inode_tree - type node_proof = P.Node_portable.proof - - let proof_of_iproof : proof_inode -> proof_tree = function - | Blinded_inode h -> Blinded_node h - | Inode_values l -> Node l - | Inode_tree i -> Inode i - | Inode_extender ext -> Extender ext - - let rec proof_of_tree : type a. irmin_tree -> (proof_tree -> a) -> a = - fun tree k -> - match tree with - | `Contents (c, h) -> proof_of_contents c h k - | `Node node -> proof_of_node node k - - and proof_of_contents : type a. - Contents.t -> metadata -> (proof_tree -> a) -> a = - fun c m k -> - match Contents.cached_value c with - | Some v -> k (Contents (v, m)) - | None -> k (Blinded_contents (Contents.hash c, m)) - - and proof_of_node : type a. node -> (proof_tree -> a) -> a = - fun node k -> - (* Let's convert [node] to [node_proof]. - - As [node] might not be exported, we can only turn it into a portable - node. *) - let to_portable_value = - let value_of_key ~cache:_ _node _repo k = - let h = P.Node.Key.to_hash k in - err_dangling_hash h - in - Node.to_portable_value_aux ~cache:false ~value_of_key ~return:Fun.id - ~bind:(fun x f -> f x) - in - match to_portable_value node with - | Error (`Dangling_hash h) -> k (Blinded_node h) - | Error (`Pruned_hash h) -> k (Blinded_node h) - | Ok v -> - (* [to_proof] may trigger reads. This is fine. *) - let node_proof = P.Node_portable.to_proof v in - proof_of_node_proof node node_proof k - - (** [of_node_proof n np] is [p] (of type [Tree.Proof.t]) which is very - similar to [np] (of type [P.Node.Val.proof]) except that the values - loaded in [n] have been expanded. *) - and proof_of_node_proof : type a. - node -> node_proof -> (proof_tree -> a) -> a = - fun node p k -> - match p with - | `Blinded h -> k (Blinded_node h) - | `Inode (length, proofs) -> - iproof_of_inode node length proofs (fun p -> proof_of_iproof p |> k) - | `Values vs -> iproof_of_values node vs (fun p -> proof_of_iproof p |> k) - - and iproof_of_node_proof : type a. - node -> node_proof -> (proof_inode -> a) -> a = - fun node p k -> - match p with - | `Blinded h -> k (Blinded_inode h) - | `Inode (length, proofs) -> iproof_of_inode node length proofs k - | `Values vs -> iproof_of_values node vs k - - and iproof_of_inode : type a. - node -> int -> (_ * node_proof) list -> (proof_inode -> a) -> a = - fun node length proofs k -> - let rec aux acc = function - | [] -> k (Inode_tree { length; proofs = List.rev acc }) - | (index, proof) :: rest -> - iproof_of_node_proof node proof (fun proof -> - aux ((index, proof) :: acc) rest) - in - (* We are dealing with an inode A. - Its children are Bs. - The children of Bs are Cs. - *) - match proofs with - | [ (index, proof) ] -> - (* A has 1 child. *) - iproof_of_node_proof node proof (function - | Inode_tree { length = length'; proofs = [ (i, p) ] } -> - (* B is an inode with 1 child, C isn't. *) - assert (length = length'); - k - (Inode_extender { length; segments = [ index; i ]; proof = p }) - | Inode_extender { length = length'; segments; proof } -> - (* B is an inode with 1 child, so is C. *) - assert (length = length'); - k - (Inode_extender - { length; segments = index :: segments; proof }) - | (Blinded_inode _ | Inode_values _ | Inode_tree _) as p -> - (* B is not an inode with 1 child. *) - k (Inode_tree { length; proofs = [ (index, p) ] })) - | _ -> aux [] proofs - - and iproof_of_values : type a. - node -> (step * Node.pnode_value) list -> (proof_inode -> a) -> a = - let findv = - let value_of_key ~cache:_ _node _repo k = - let h = P.Node.Key.to_hash k in - err_dangling_hash h - in - Node.findv_aux ~value_of_key ~return:Fun.id ~bind:(fun x f -> f x) - in - fun node steps k -> - let rec aux acc = function - | [] -> k (Inode_values (List.rev acc)) - | (step, _) :: rest -> ( - match findv ~cache:false "Proof.iproof_of_values" node step with - | None -> assert false - | Some t -> - let k p = aux ((step, p) :: acc) rest in - proof_of_tree t k) - in - aux [] steps - - let of_tree t = proof_of_tree t Fun.id - - let rec load_proof : type a. env:_ -> proof_tree -> (kinded_hash -> a) -> a - = - fun ~env p k -> - match p with - | Blinded_node h -> k (`Node h) - | Node n -> load_node_proof ~env n k - | Inode { length; proofs } -> load_inode_proof ~env length proofs k - | Blinded_contents (h, m) -> k (`Contents (h, m)) - | Contents (v, m) -> - let h = P.Contents.Hash.hash v in - Env.add_contents_from_proof env h v; - k (`Contents (h, m)) - | Extender { length; segments; proof } -> - load_extender_proof ~env length segments proof k - - (* Recontruct private node from [P.Node.Val.proof] *) - and load_extender_proof : type a. - env:_ -> int -> int list -> proof_inode -> (kinded_hash -> a) -> a = - fun ~env len segments p k -> - node_proof_of_proof ~env p (fun p -> - let np = proof_of_extender len segments p in - let v = P.Node_portable.of_proof ~depth:0 np in - let v = - match v with - | None -> Proof.bad_proof_exn "Invalid proof" - | Some v -> v - in - let h = P.Node_portable.hash_exn v in - Env.add_pnode_from_proof env h v; - k (`Node h)) - - and proof_of_extender len segments p : node_proof = - List.fold_left - (fun acc index -> `Inode (len, [ (index, acc) ])) - p (List.rev segments) - - (* Recontruct private node from [P.Node.Val.empty] *) - and load_node_proof : type a. - env:_ -> (step * proof_tree) list -> (kinded_hash -> a) -> a = - fun ~env n k -> - let rec aux acc = function - | [] -> - let h = P.Node_portable.hash_exn acc in - Env.add_pnode_from_proof env h acc; - k (`Node h) - | (s, p) :: rest -> - let k h = aux (P.Node_portable.add acc s h) rest in - load_proof ~env p k - in - aux (P.Node_portable.empty ()) n - - (* Recontruct private node from [P.Node.Val.proof] *) - and load_inode_proof : type a. - env:_ -> int -> (_ * proof_inode) list -> (kinded_hash -> a) -> a = - fun ~env len proofs k -> - let rec aux : _ list -> _ list -> a = - fun acc proofs -> - match proofs with - | [] -> - let np = `Inode (len, List.rev acc) in - let v = P.Node_portable.of_proof ~depth:0 np in - let v = - match v with - | None -> Proof.bad_proof_exn "Invalid proof" - | Some v -> v - in - let h = P.Node_portable.hash_exn v in - Env.add_pnode_from_proof env h v; - k (`Node h) - | (i, p) :: rest -> - let k p = aux ((i, p) :: acc) rest in - node_proof_of_proof ~env p k - in - aux [] proofs - - and node_proof_of_proof : type a. - env:_ -> proof_inode -> (node_proof -> a) -> a = - fun ~env t k -> - match t with - | Blinded_inode x -> k (`Blinded x) - | Inode_tree { length; proofs } -> - node_proof_of_inode ~env length proofs k - | Inode_values n -> node_proof_of_node ~env n k - | Inode_extender { length; segments; proof } -> - node_proof_of_proof ~env proof (fun p -> - k (proof_of_extender length segments p)) - - and node_proof_of_inode : type a. - env:_ -> int -> (_ * proof_inode) list -> (node_proof -> a) -> a = - fun ~env length proofs k -> - let rec aux acc = function - | [] -> k (`Inode (length, List.rev acc)) - | (i, p) :: rest -> - node_proof_of_proof ~env p (fun p -> aux ((i, p) :: acc) rest) - in - aux [] proofs - - and node_proof_of_node : type a. - env:_ -> (step * proof_tree) list -> (node_proof -> a) -> a = - fun ~env node k -> - let rec aux acc = function - | [] -> k (`Values (List.rev acc)) - | (s, p) :: rest -> - load_proof ~env p (fun n -> aux ((s, n) :: acc) rest) - in - aux [] node - - let to_tree p = - let env = Env.empty () in - Env.set_mode env Env.Deserialise; - let h = load_proof ~env (state p) Fun.id in - let tree = pruned_with_env ~env h in - Env.set_mode env Env.Consume; - tree - end - - let produce_proof repo kinded_key f = - Env.with_produce @@ fun env ~start_serialise -> - let tree = import_with_env ~env repo kinded_key in - let+ tree_after, result = f tree in - let after = hash tree_after in - (* Here, we build a proof from [tree] (not from [tree_after]!), on purpose: - we look at the effect on [f] on [tree]'s caches and we rely on the fact - that the caches are env across copy-on-write copies of [tree]. *) - clear tree; - start_serialise (); - let proof = Proof.of_tree tree in - (* [env] will be purged when leaving the scope, that should avoid any memory - leaks *) - let kinded_hash = Node.weaken_value kinded_key in - (Proof.v ~before:kinded_hash ~after proof, result) - - let verify_proof_exn p f = - Env.with_consume @@ fun env ~stop_deserialise -> - let before = Proof.before p in - let after = Proof.after p in - (* First convert to proof to [Env] *) - let h = Proof.(load_proof ~env (state p) Fun.id) in - (* Then check that the consistency of the proof *) - if not (equal_kinded_hash before h) then - Irmin_proof.bad_proof_exn "verify_proof: invalid before hash"; - let tree = pruned_with_env ~env h in - Lwt.catch - (fun () -> - stop_deserialise (); - (* Then apply [f] on a cleaned tree, an exception will be raised if [f] - reads out of the proof. *) - let+ tree_after, result = f tree in - (* then check that [after] corresponds to [tree_after]'s hash. *) - if not (equal_kinded_hash after (hash tree_after)) then - Irmin_proof.bad_proof_exn "verify_proof: invalid after hash"; - (tree_after, result)) - (function - | Pruned_hash h -> - (* finaly check that [f] only access valid parts of the proof. *) - Fmt.kstr Irmin_proof.bad_proof_exn - "verify_proof: %s is trying to read through a blinded node or \ - object (%a)" - h.context pp_hash h.hash - | e -> raise e) - - type verifier_error = [ `Proof_mismatch of string ] [@@deriving irmin] - - let verify_proof p f = - Lwt.catch - (fun () -> - let+ r = verify_proof_exn p f in - Ok r) - (function - | Irmin_proof.Bad_proof e -> - Lwt.return (Error (`Proof_mismatch e.context)) - | e -> Lwt.fail e) - - let hash_of_proof_state state = - let env = Env.empty () in - Proof.load_proof ~env state Fun.id - - module Private = struct - let get_env = get_env - - module Env = Env - end -end +include Tree_intf diff --git a/src/irmin-lwt/core/tree_intf.ml b/src/irmin-lwt/core/tree_intf.ml index 2b9ce0526f..a1f2b1f81b 100644 --- a/src/irmin-lwt/core/tree_intf.ml +++ b/src/irmin-lwt/core/tree_intf.ml @@ -17,6 +17,29 @@ 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] @@ -331,7 +354,7 @@ module type S = sig (** {1 Stats} *) - type stats = { + type nonrec stats = stats = { nodes : int; (** Number of node. *) leafs : int; (** Number of leafs. *) skips : int; (** Number of lazy nodes. *) @@ -391,7 +414,7 @@ module type S = sig (** {1 Performance counters} *) - type counters = { + type nonrec counters = counters = { mutable contents_hash : int; mutable contents_find : int; mutable contents_add : int; @@ -442,55 +465,4 @@ module type Sigs = sig include S (** @inline *) end - - module Make (B : Backend.S) : sig - include - S - with type path = B.Node.Path.t - and type step = B.Node.Path.step - and type metadata = B.Node.Metadata.t - and type contents = B.Contents.value - and type contents_key = B.Contents.Key.t - and type hash = B.Hash.t - - type kinded_key = - [ `Contents of B.Contents.Key.t * metadata | `Node of B.Node.Key.t ] - [@@deriving irmin] - - val import : B.Repo.t -> kinded_key -> t option Lwt.t - val import_no_check : B.Repo.t -> kinded_key -> t - - val export : - ?clear:bool -> - B.Repo.t -> - [> write ] B.Contents.t -> - [> read_write ] B.Node.t -> - node -> - B.Node.key Lwt.t - - val dump : t Fmt.t - val equal : t -> t -> bool - val key : t -> kinded_key option - val hash : ?cache:bool -> t -> kinded_hash - val to_backend_node : node -> B.Node.Val.t Lwt.t - val to_backend_portable_node : node -> B.Node_portable.t Lwt.t - val of_backend_node : B.Repo.t -> B.Node.value -> node - - type 'result producer := - B.Repo.t -> - kinded_key -> - (t -> (t * 'result) Lwt.t) -> - (Proof.t * 'result) Lwt.t - - type verifier_error = [ `Proof_mismatch of string ] [@@deriving irmin] - - type 'result verifier := - Proof.t -> - (t -> (t * 'result) Lwt.t) -> - (t * 'result, verifier_error) result Lwt.t - - val produce_proof : 'a producer - val verify_proof : 'a verifier - val hash_of_proof_state : Proof.tree -> kinded_hash - end end From 86e716bd934d1149b89303ec1711910d1148db8f Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:04:37 +0200 Subject: [PATCH 05/26] irmin-lwt: alias [Closed] to [Irmin.Closed] [main:src/irmin/store_properties.ml] declared a fresh [exception Closed]. With Irmin 4 layered underneath, exceptions raised by the Eio backend through [Lwt_eio.run_eio] would be of type [Irmin.Closed] (the Eio one), not the local fresh [Closed]. User code that wrote [Lwt.catch ... (function Irmin.Closed -> ...)] would silently miss those exceptions. Aliasing the local [Closed] to [Irmin.Closed] makes the two constructors equal -- pattern matching on either reaches the same exception value. --- src/irmin-lwt/core/store_properties.ml | 21 ++++----------------- 1 file changed, 4 insertions(+), 17 deletions(-) diff --git a/src/irmin-lwt/core/store_properties.ml b/src/irmin-lwt/core/store_properties.ml index 8485c2f65e..d76495a7bc 100644 --- a/src/irmin-lwt/core/store_properties.ml +++ b/src/irmin-lwt/core/store_properties.ml @@ -1,19 +1,6 @@ -(* - * 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 -exception Closed +(* 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 From f06f0c3b90c233e2ddd3816f015b6dcf556f9c5d Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:05:00 +0200 Subject: [PATCH 06/26] irmin-lwt: reduce non-Lwt modules to re-exports of Irmin 4 Twelve modules in [main:src/irmin/] are pure (no [Lwt.t] / [Merge.t] / no Lwt-typed sub-stores in their signatures): they're identical in shape between Irmin 3 and Irmin 4. Rather than carry a separate copy in the shim, each is reduced to a one-line transparent re-export of the Irmin 4 module. The list: - [path.ml] -> [include Irmin.Path] - [hash.ml] -> [include Irmin.Hash] - [info.ml] -> [include Irmin.Info] - [conf.ml] / [conf.mli] -> re-export [Irmin.Backend.Conf] - [key.ml] -> [include Irmin.Key] - [diff.ml] -> [include Irmin.Diff] - [perms.ml] -> [include Irmin.Perms] - [export_for_backends.ml] -> [include Irmin.Export_for_backends] - [type.ml] -> [include Repr] + a small [Defaultable] local type - [metrics.ml] -> [include Irmin.Metrics] - [append_only.ml] -> collapsed to [include Append_only_intf] (alongside its existing [_intf.ml]) - [read_only.ml] -> collapsed to [include Read_only_intf] --- src/irmin-lwt/core/append_only.ml | 16 -- src/irmin-lwt/core/conf.ml | 179 +--------------------- src/irmin-lwt/core/conf.mli | 156 +------------------ src/irmin-lwt/core/diff.ml | 19 +-- src/irmin-lwt/core/export_for_backends.ml | 22 +-- src/irmin-lwt/core/hash.ml | 119 +------------- src/irmin-lwt/core/info.ml | 42 +---- src/irmin-lwt/core/key.ml | 26 +--- src/irmin-lwt/core/metrics.ml | 46 +----- src/irmin-lwt/core/path.ml | 49 +----- src/irmin-lwt/core/perms.ml | 68 +------- src/irmin-lwt/core/read_only.ml | 16 -- src/irmin-lwt/core/type.ml | 16 -- 13 files changed, 15 insertions(+), 759 deletions(-) diff --git a/src/irmin-lwt/core/append_only.ml b/src/irmin-lwt/core/append_only.ml index 2075b21c1c..3a08f97487 100644 --- a/src/irmin-lwt/core/append_only.ml +++ b/src/irmin-lwt/core/append_only.ml @@ -1,17 +1 @@ -(* - * 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 diff --git a/src/irmin-lwt/core/conf.ml b/src/irmin-lwt/core/conf.ml index 42e3688dde..8ed94f78a6 100644 --- a/src/irmin-lwt/core/conf.ml +++ b/src/irmin-lwt/core/conf.ml @@ -1,178 +1 @@ -(* - * Copyright (c) 2013-2022 Thomas Gazagnaire - * Copyright (c) 2017 Daniel C. Bünzli - * - * 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 Univ = struct - type t = exn - - let create (type s) () = - let module M = struct - exception E of s option - end in - ((fun x -> M.E (Some x)), function M.E x -> x | _ -> None) -end - -type 'a key = { - name : string; - doc : string option; - docv : string option; - docs : string option; - ty : 'a Type.t; - default : 'a; - to_univ : 'a -> Univ.t; - of_univ : Univ.t -> 'a option; -} - -type k = K : 'a key -> k - -module M = Map.Make (struct - type t = k - - let compare (K a) (K b) = String.compare a.name b.name -end) - -module Spec = struct - module M = Map.Make (String) - - type t = { name : string; mutable keys : k M.t } - - let all = Hashtbl.create 8 - - let v name = - let keys = M.empty in - if Hashtbl.mem all name then - Fmt.failwith "Config spec already exists: %s" name; - let x = { name; keys } in - Hashtbl.replace all name x; - x - - let name { name; _ } = name - let update spec name k = spec.keys <- M.add name k spec.keys - let list () = Hashtbl.to_seq_values all - let find name = Hashtbl.find_opt all name - let find_key spec name = M.find_opt name spec.keys - let keys spec = M.to_seq spec.keys |> Seq.map snd - let clone { name; keys } = { name; keys } - - let join dest src = - let dest = clone dest in - let name = ref dest.name in - let keys = - List.fold_left - (fun acc spec -> - if dest.name = spec.name then acc - else - let () = name := !name ^ "-" ^ spec.name in - M.add_seq (M.to_seq spec.keys) acc) - dest.keys src - in - { name = !name; keys } -end - -type t = Spec.t * Univ.t M.t - -let spec = fst - -let key ?docs ?docv ?doc ~spec name ty default = - let () = - String.iter - (function - | '-' | '_' | 'a' .. 'z' | '0' .. '9' -> () - | _ -> raise @@ Invalid_argument name) - name - in - match Spec.find_key spec name with - | Some _ -> Fmt.invalid_arg "duplicate key: %s" name - | _ -> - let to_univ, of_univ = Univ.create () in - let k = { name; ty; default; to_univ; of_univ; doc; docv; docs } in - Spec.update spec name (K k); - k - -let name t = t.name -let doc t = t.doc -let docv t = t.docv -let docs t = t.docs -let ty t = t.ty -let default t = t.default -let empty spec = (spec, M.empty) -let singleton spec k v = (spec, M.singleton (K k) (k.to_univ v)) -let is_empty (_, t) = M.is_empty t -let mem (_, d) k = M.mem (K k) d - -let validate_key spec k = - match Spec.find_key spec k.name with - | None -> Fmt.invalid_arg "invalid config key: %s" k.name - | Some _ -> () - -let add (spec, d) k v = - validate_key spec k; - (spec, M.add (K k) (k.to_univ v) d) - -let verify (spec, d) = - M.iter (fun (K k) _ -> validate_key spec k) d; - (spec, d) - -let union (rs, r) (ss, s) = - let spec = Spec.join rs [ ss ] in - (spec, M.fold M.add r s) - -let rem (s, d) k = (s, M.remove (K k) d) -let find (_, d) k = try k.of_univ (M.find (K k) d) with Not_found -> None -let uri = Type.(map string) Uri.of_string Uri.to_string - -let get (_, d) k = - try - match k.of_univ (M.find (K k) d) with - | Some v -> v - | None -> raise Not_found - with Not_found -> k.default - -let keys (_, conf) = M.to_seq conf |> Seq.map (fun (k, _) -> k) -let with_spec (_, conf) spec = (spec, conf) - -let to_strings (_, conf) = - conf - |> M.to_seq - |> Seq.map (fun (K k, v) -> - ( k.name, - match k.of_univ v with - | Some v -> Type.to_string k.ty v - | None -> assert false )) - -let pp ppf t = - t |> to_strings |> List.of_seq |> Fmt.Dump.(list (pair string string)) ppf - -let equal t1 t2 = - t1 == t2 - || Seq.for_all2 - (fun (k1, v1) (k2, v2) -> String.equal k1 k2 && String.equal v1 v2) - (to_strings t1) (to_strings t2) - -(* ~root *) -let root spec = - key ~spec ~docv:"ROOT" ~doc:"The location of the Irmin store on disk." - ~docs:"COMMON OPTIONS" "root" - Type.(string) - "." - -let find_root (spec, d) : string option = - match Spec.find_key spec "root" with - | None -> None - | Some (K k) -> ( - let v = find (spec, d) k in - match v with None -> None | Some v -> Some (Type.to_string k.ty v)) +include Irmin.Backend.Conf diff --git a/src/irmin-lwt/core/conf.mli b/src/irmin-lwt/core/conf.mli index e850a49d2a..ac41a864c1 100644 --- a/src/irmin-lwt/core/conf.mli +++ b/src/irmin-lwt/core/conf.mli @@ -1,5 +1,5 @@ (* - * Copyright (c) 2013-2022 Thomas Gazagnaire + * 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 @@ -14,154 +14,10 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -(** {1 Configuration converters} +(** Backend configuration. - A configuration converter transforms a string value to an OCaml value and - vice-versa. *) + [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}. *) -(** {1:keys Keys} *) - -type 'a key -(** The type for configuration keys whose lookup value is ['a]. *) - -type k = K : 'a key -> k - -module Spec : sig - type t - (** A configuration spec is used to group keys by backend *) - - val v : string -> t - (** [v name] is a new configuration specification named [name] *) - - val name : t -> string - (** [name spec] is the name associated with a config spec *) - - val list : unit -> t Seq.t - (** [list ()] is a sequence containing all available config specs *) - - val find : string -> t option - (** [find name] is the config spec associated with [name] if available *) - - val find_key : t -> string -> k option - (** [find_key spec k] is the key associated with the name [k] in [spec] *) - - val keys : t -> k Seq.t - (** [keys spec] is a sequence of keys available in [spec] *) - - val join : t -> t list -> t - (** [join a b] is a new [Spec.t] combining [a] and all specs present in [b] - - The name of the resulting spec will be the name of [a] and the names of - the specs in [b] joined by hyphens. *) -end - -val key : - ?docs:string -> - ?docv:string -> - ?doc:string -> - spec:Spec.t -> - string -> - 'a Type.t -> - 'a -> - 'a key -(** [key ~docs ~docv ~doc ~spec name conv default] is a configuration key named - [name] that maps to value [default] by default. It will be associated with - the config grouping [spec]. [conv] is used to convert key values provided by - end users. - - [docs] is the title of a documentation section under which the key is - documented. [doc] is a short documentation string for the key, this should - be a single sentence or paragraph starting with a capital letter and ending - with a dot. [docv] is a meta-variable for representing the values of the key - (e.g. ["BOOL"] for a boolean). - - @raise Invalid_argument - if the key name is not made of a sequence of ASCII lowercase letter, - digit, dash or underscore. - @raise Invalid_argument - if [allow_duplicate] is [false] (the default) and [name] has already been - used to create a key *) - -val name : 'a key -> string -(** The key name. *) - -val ty : 'a key -> 'a Type.t -(** [tc k] is [k]'s converter. *) - -val default : 'a key -> 'a -(** [default k] is [k]'s default value. *) - -val doc : 'a key -> string option -(** [doc k] is [k]'s documentation string (if any). *) - -val docv : 'a key -> string option -(** [docv k] is [k]'s value documentation meta-variable (if any). *) - -val docs : 'a key -> string option -(** [docs k] is [k]'s documentation section (if any). *) - -val root : Spec.t -> string key -(** Default [--root=ROOT] argument. *) - -(** {1:conf Configurations} *) - -type t -(** The type for configurations. *) - -val pp : t Fmt.t -(** [pp] is the pretty printer for configuration values. *) - -val equal : t -> t -> bool -(** [equal] is the equality for configuration values. Two values are equal if - they have the same [pp] representation. *) - -val spec : t -> Spec.t -(** [spec c] is the specification associated with [c] *) - -val empty : Spec.t -> t -(** [empty spec] is an empty configuration. *) - -val singleton : Spec.t -> 'a key -> 'a -> t -(** [singleton spec k v] is the configuration where [k] maps to [v]. *) - -val is_empty : t -> bool -(** [is_empty c] is [true] iff [c] is empty. *) - -val mem : t -> 'a key -> bool -(** [mem c k] is [true] iff [k] has a mapping in [c]. *) - -val add : t -> 'a key -> 'a -> t -(** [add c k v] is [c] with [k] mapping to [v]. *) - -val rem : t -> 'a key -> t -(** [rem c k] is [c] with [k] unbound. *) - -val union : t -> t -> t -(** [union r s] is the union of the configurations [r] and [s]. *) - -val find : t -> 'a key -> 'a option -(** [find c k] is [k]'s mapping in [c], if any. *) - -val get : t -> 'a key -> 'a -(** [get c k] is [k]'s mapping in [c]. - - {b Raises.} [Not_found] if [k] is not bound in [d]. *) - -val keys : t -> k Seq.t -(** [keys c] is a sequence of all keys present in [c] *) - -val with_spec : t -> Spec.t -> t -(** [with_spec t s] is the config [t] with spec [s] *) - -val verify : t -> t -(** [verify t] is an identity function that ensures all keys match the spec - - {b Raises.} [Invalid_argument] if [t] contains invalid keys *) - -(** {1:builtin_converters Built-in value converters} *) - -val uri : Uri.t Type.t -(** [uri] converts values with {!Uri.of_string}. *) - -val find_root : t -> string option -(** [find_root c] is [root]'s mapping in [c], if any. *) +include module type of Irmin.Backend.Conf diff --git a/src/irmin-lwt/core/diff.ml b/src/irmin-lwt/core/diff.ml index 8e0e4d2773..89a39f908a 100644 --- a/src/irmin-lwt/core/diff.ml +++ b/src/irmin-lwt/core/diff.ml @@ -1,18 +1 @@ -(* - * 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. - *) - -type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] -[@@deriving irmin] +include Irmin.Diff diff --git a/src/irmin-lwt/core/export_for_backends.ml b/src/irmin-lwt/core/export_for_backends.ml index 507a4913b6..6f1b909c9f 100644 --- a/src/irmin-lwt/core/export_for_backends.ml +++ b/src/irmin-lwt/core/export_for_backends.ml @@ -1,21 +1 @@ -(* - * 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 Store_properties = Store_properties -module Logging = Logging -module Reversed_list = Reversed_list -include Import +include Irmin.Export_for_backends diff --git a/src/irmin-lwt/core/hash.ml b/src/irmin-lwt/core/hash.ml index c99a0a620d..5236a732bf 100644 --- a/src/irmin-lwt/core/hash.ml +++ b/src/irmin-lwt/core/hash.ml @@ -1,118 +1 @@ -(* - * 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 Hash_intf - -module Make (H : Digestif.S) = struct - type t = H.t - - external get_64 : string -> int -> int64 = "%caml_string_get64u" - external swap64 : int64 -> int64 = "%bswap_int64" - - let get_64_little_endian str idx = - if Sys.big_endian then swap64 (get_64 str idx) else get_64 str idx - - let short_hash c = Int64.to_int (get_64_little_endian (H.to_raw_string c) 0) - - let short_hash_substring bigstring ~off = - Int64.to_int (Bigstringaf.get_int64_le bigstring off) - - let hash_size = H.digest_size - - let of_hex s = - match H.consistent_of_hex s with - | x -> Ok x - | exception Invalid_argument e -> Error (`Msg e) - - let pp_hex ppf x = Fmt.string ppf (H.to_hex x) - - let t = - Type.map ~pp:pp_hex ~of_string:of_hex - Type.(string_of (`Fixed hash_size)) - H.of_raw_string H.to_raw_string - - let hash s = H.digesti_string s - let to_raw_string s = H.to_raw_string s - let unsafe_of_raw_string s = H.of_raw_string s -end - -module Make_BLAKE2B (D : sig - val digest_size : int -end) = - Make (Digestif.Make_BLAKE2B (D)) - -module Make_BLAKE2S (D : sig - val digest_size : int -end) = - Make (Digestif.Make_BLAKE2S (D)) - -module SHA1 = Make (Digestif.SHA1) -module RMD160 = Make (Digestif.RMD160) -module SHA224 = Make (Digestif.SHA224) -module SHA256 = Make (Digestif.SHA256) -module SHA384 = Make (Digestif.SHA384) -module SHA512 = Make (Digestif.SHA512) -module BLAKE2B = Make (Digestif.BLAKE2B) -module BLAKE2S = Make (Digestif.BLAKE2S) - -module Typed (K : S) (V : Type.S) = struct - include K - - type value = V.t [@@deriving irmin ~pre_hash] - - let hash v = K.hash (pre_hash_value v) -end - -module V1 (K : S) : S with type t = K.t = struct - type t = K.t [@@deriving irmin ~encode_bin ~decode_bin] - - let hash = K.hash - let short_hash = K.short_hash - let short_hash_substring = K.short_hash_substring - let hash_size = K.hash_size - let int64_to_bin_string = Type.(unstage (to_bin_string int64)) - let hash_size_str = int64_to_bin_string (Int64.of_int K.hash_size) - let to_raw_string = K.to_raw_string - let unsafe_of_raw_string = K.unsafe_of_raw_string - - let encode_bin e f = - f hash_size_str; - encode_bin e f - - let decode_bin buf pos_ref = - pos_ref := !pos_ref + 8; - decode_bin buf pos_ref - - let size_of = Type.Size.custom_static (8 + hash_size) - let t = Type.like K.t ~bin:(encode_bin, decode_bin, size_of) -end - -module Set = struct - module Make (Hash : S) = struct - include Irmin_data.Fixed_size_string_set - - let create ?(initial_slots = 0) () = - let elt_length = Hash.hash_size - and hash s = Hash.(short_hash (unsafe_of_raw_string s)) - and hash_substring t ~off ~len:_ = Hash.short_hash_substring t ~off in - create ~elt_length ~initial_slots ~hash ~hash_substring () - - let add t h = add t (Hash.to_raw_string h) - let mem t h = mem t (Hash.to_raw_string h) - end - - module type S = Set -end +include Irmin.Hash diff --git a/src/irmin-lwt/core/info.ml b/src/irmin-lwt/core/info.ml index 9cf6d34042..aed7cf81b1 100644 --- a/src/irmin-lwt/core/info.ml +++ b/src/irmin-lwt/core/info.ml @@ -1,41 +1 @@ -(* - * 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 Info_intf - -module Default = struct - type author = string [@@deriving irmin] - type message = string [@@deriving irmin] - - type t = { date : int64; author : author; message : message } - [@@deriving irmin ~equal] - - type f = unit -> t - - let empty = { date = 0L; author = ""; message = "" } - let is_empty = equal empty - - let v ?(author = "") ?(message = "") date = - let r = { date; message; author } in - if is_empty r then empty else r - - let date t = t.date - let author t = t.author - let message t = t.message - let none () = empty -end - -type default = Default.t +include Irmin.Info diff --git a/src/irmin-lwt/core/key.ml b/src/irmin-lwt/core/key.ml index c7b86c388e..942c555853 100644 --- a/src/irmin-lwt/core/key.ml +++ b/src/irmin-lwt/core/key.ml @@ -1,25 +1 @@ -(* - * 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 Key_intf - -module Of_hash (Hash : Type.S) = struct - type t = Hash.t [@@deriving irmin] - type hash = Hash.t - - let to_hash x = x [@@inline] - let of_hash x = x [@@inline] -end +include Irmin.Key diff --git a/src/irmin-lwt/core/metrics.ml b/src/irmin-lwt/core/metrics.ml index e531bdc580..c9075996c9 100644 --- a/src/irmin-lwt/core/metrics.ml +++ b/src/irmin-lwt/core/metrics.ml @@ -1,45 +1 @@ -(* - * Copyright (c) 2022 - Étienne Marais - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -let uid = - let id = ref (-1) in - fun () -> - incr id; - !id - -type origin = .. - -type 'a t = { - uid : int; - name : string; - origin : origin option; - repr : 'a Repr.ty; - mutable state : 'a; -} - -let state m = m.state -let set_state m v = m.state <- v - -type 'a update_mode = Mutate of ('a -> unit) | Replace of ('a -> 'a) - -let v : type a. - ?origin:origin -> name:string -> initial_state:a -> a Repr.ty -> a t = - fun ?origin ~name ~initial_state repr -> - { uid = uid (); origin; name; repr; state = initial_state } - -let update : type a. a t -> a update_mode -> unit = - fun m kind -> - match kind with Mutate f -> f m.state | Replace f -> m.state <- f m.state +include Irmin.Metrics diff --git a/src/irmin-lwt/core/path.ml b/src/irmin-lwt/core/path.ml index 95b73760b6..2d021997e3 100644 --- a/src/irmin-lwt/core/path.ml +++ b/src/irmin-lwt/core/path.ml @@ -1,48 +1 @@ -(* - * 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 Astring -include Path_intf - -module String_list = struct - type step = string [@@deriving irmin] - type t = step list - - let empty = [] - let is_empty l = l = [] - let cons s t = s :: t - let rcons t s = t @ [ s ] - let decons = function [] -> None | h :: t -> Some (h, t) - - let rdecons l = - match List.rev l with [] -> None | h :: t -> Some (List.rev t, h) - - let map l f = List.map f l - let v x = x - - let pp ppf t = - let len = List.fold_left (fun acc s -> 1 + acc + String.length s) 1 t in - let buf = Buffer.create len in - List.iter - (fun s -> - Buffer.add_char buf '/'; - Buffer.add_string buf s) - t; - Fmt.string ppf (Buffer.contents buf) - - let of_string s = Ok (List.filter (( <> ) "") (String.cuts s ~sep:"/")) - let t = Type.like ~pp ~of_string Type.(list step_t) -end +include Irmin.Path diff --git a/src/irmin-lwt/core/perms.ml b/src/irmin-lwt/core/perms.ml index 8da4ae207a..9f4bb7b944 100644 --- a/src/irmin-lwt/core/perms.ml +++ b/src/irmin-lwt/core/perms.ml @@ -1,67 +1 @@ -(* - * 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. - *) - -(** Types representing {i permissions} ['perms] for performing operations on a - certain type ['perms t]. - - They are intended to be used as phantom parameters of the types that they - control access to. As an example, consider the following type of references - with permissions: - - {[ - module Ref : sig - type (+'a, -'perms) t - - val create : 'a -> ('a, read_write) t - val get : ('a, [> read ]) t -> 'a - val set : ('a, [> write ]) t -> 'a -> unit - end - ]} - - This type allows references to be created with arbitrary read-write access. - One can then create weaker views onto the reference – with access to fewer - operations – by upcasting: - - {[ - let read_only t = (t :> (_, read) Ref.t) - let write_only t = (t :> (_, write) Ref.t) - ]} - - Note that the ['perms] phantom type parameter should be contravariant: it's - safe to discard permissions, but not to gain new ones. *) - -module Read = struct - type t = [ `Read ] -end - -module Write = struct - type t = [ `Write ] -end - -module Read_write = struct - type t = [ Read.t | Write.t ] -end - -type read = Read.t -(** The type parameter of a handle with [read] permissions. *) - -type write = Write.t -(** The type parameter of a handle with [write] permissions. *) - -type read_write = Read_write.t -(** The type parameter of a handle with both {!read} and {!write} permissions. -*) +include Irmin.Perms diff --git a/src/irmin-lwt/core/read_only.ml b/src/irmin-lwt/core/read_only.ml index 95cc3d33a0..d1765fa4b0 100644 --- a/src/irmin-lwt/core/read_only.ml +++ b/src/irmin-lwt/core/read_only.ml @@ -1,17 +1 @@ -(* - * 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 diff --git a/src/irmin-lwt/core/type.ml b/src/irmin-lwt/core/type.ml index dbf9c23465..a053b98efd 100644 --- a/src/irmin-lwt/core/type.ml +++ b/src/irmin-lwt/core/type.ml @@ -1,19 +1,3 @@ -(* - * 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 Repr module type Defaultable = sig From 21b7924ef44a77fa2df639b6d31108be1abb59f6 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:05:15 +0200 Subject: [PATCH 07/26] irmin-lwt: alias [Remote.t] to [Irmin.remote] (extensible variant unification) Without this alias, the shim's [Remote.t] and [Irmin.remote] are two distinct extensible variants. Constructors added by Irmin 4 backends (notably [Backend.E of endpoint] inside any [Inner] store) cannot be re-exported from the shim's surface. Declaring [type t = Irmin.remote = ..] makes them the same type and lets [Wrap_store.Make] forward the inner [E] constructor with [type Remote.t += E = Inner.E]. --- src/irmin-lwt/core/remote_intf.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/irmin-lwt/core/remote_intf.ml b/src/irmin-lwt/core/remote_intf.ml index 4237c9a058..1bf89ff43c 100644 --- a/src/irmin-lwt/core/remote_intf.ml +++ b/src/irmin-lwt/core/remote_intf.ml @@ -14,7 +14,9 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -type t = .. +(* 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} *) From b2221b001971e0676dbc6cec9a491080fb4a4d19 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:05:35 +0200 Subject: [PATCH 08/26] irmin-lwt: add Lwt_to_eio adapter functors (new code) A collection of bidirectional adapter functors between the shim's Lwt-typed module types and Irmin 4's Eio-typed module types. Each adapter wraps a function via [Lwt_eio.run_eio] (Eio direct -> Lwt.t) or [Lwt_eio.Promise.await_lwt] (Lwt.t -> Eio direct), depending on direction. Provides: - [merge_of_eio] / [merge_to_eio] -- bridge [Irmin.Merge.t] to / from [Merge.t] for a given type descriptor. - [Metadata] / [Contents] -- lift Lwt-typed Schema sub-modules to [Irmin.Metadata.S] / [Irmin.Contents.S]. - [Schema] / [Schema_extended] -- lift a Lwt [Schema.S] to [Irmin.Schema.S] / [Irmin.Schema.Extended] for backends like [Irmin_pack_unix.Maker] that need [Extended]. - [Indexable_of_eio] / [Atomic_write_of_eio] -- Eio store -> Lwt store wrappers, one operation per call. - [Indexable_to_eio] / [Atomic_write_to_eio] -- mirror direction. - [Content_addressable] / [Atomic_write] / [Append_only] -- Lwt Maker -> Eio Maker bridges, used to feed user-supplied Lwt backend Makers into [Irmin.Maker]. Used internally by [Wrap_store], [Maker_v2], and per-package shims. --- src/irmin-lwt/core/lwt_to_eio.ml | 313 +++++++++++++++++++++++++++++++ 1 file changed, 313 insertions(+) create mode 100644 src/irmin-lwt/core/lwt_to_eio.ml 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 From 0fafd42f630362d9c0276d36dc4896d2e11930d8 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:05:56 +0200 Subject: [PATCH 09/26] irmin-lwt: add Wrap_store -- generic Lwt wrap of any Eio Generic_key.S (new code) [Wrap_store.Make (S : Schema.S) (Schema_eio : Irmin.Schema.S with ...) (Inner : Irmin.Generic_key.S with module Schema = Schema_eio)] produces a Lwt-typed [Generic_key.S] whose [Schema] is the user's input [S] and whose effectful operations forward to [Inner] through [Lwt_eio.run_eio]. This is the core of the shim. Every backend produced by [irmin-lwt] goes through it: the per-package shim builds an Eio [Inner] and passes it to [Wrap_store.Make] alongside the user's Lwt-typed [Schema] and a parallel Eio-typed [Schema_eio] (constructed via [Lwt_to_eio.Schema] or [Lwt_to_eio.Schema_extended]). Wraps: - types [repo, t, contents, contents_key, node_key, commit_key, hash, metadata, tree, ...] (passed through from [Inner]) - top-level read and write ops ([find / mem / set_exn / test_and_set / merge / ...]) - 35+ ops - [Repo] sub-module (v / close / heads / branches / batch / export / import / ...) - [Branch] sub-module (Atomic_write-like ops with watch callbacks bridged) - [Head] / [Commit] / [Info] / [Status] / [Hash] sub-modules - [Tree] sub-module (in-memory tree ops, sub-modules including [Proof] / [Private] / converters / [counters] hoisted to top for nominal type identity) - [Backend] sub-module (Slice with iter callbacks bridged, Branch re-exposed, Repo with batch bridged, Remote, plus Node and Commit with their merges bridged via [merge_of_eio]) - [Sync.E] forwarded as [Inner.E] for cross-store remote endpoints Result: the user gets a fully Lwt-flavoured [Generic_key.S] backed by an Irmin 4 store. --- src/irmin-lwt/core/wrap_store.ml | 816 +++++++++++++++++++++++++++++++ 1 file changed, 816 insertions(+) create mode 100644 src/irmin-lwt/core/wrap_store.ml 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 From f32260bf4296ab0887c3168fff86441d38a0e6ff Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:06:34 +0200 Subject: [PATCH 10/26] irmin-lwt: add Maker_v2 -- Lwt Maker via Wrap_store (new code) [Maker_v2.Make (CA) (AW) (S)] is the Lwt-flavoured [Irmin.Maker] implementation: module CA_eio (H) (V) = Lwt_to_eio.Content_addressable (CA) (H) (V) module AW_eio (K) (V) = Lwt_to_eio.Atomic_write (AW) (K) (V) 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) The user's Lwt-typed sub-Makers are bridged to Eio, fed to [Irmin.Maker], and the resulting Eio store is wrapped back to a Lwt-typed [Generic_key.S] via [Wrap_store.Make]. --- src/irmin-lwt/core/maker_v2.ml | 40 ++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 src/irmin-lwt/core/maker_v2.ml 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 From efc83e7a437f11912aa1439bc3b1170ddc768b9e Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:07:03 +0200 Subject: [PATCH 11/26] irmin-lwt: top-level Irmin_lwt.{ml,mli} + dune file (new code) The shim's public entry point. The .mli is structured like [main:src/irmin/irmin.mli] (same module layout, same modules exposed at top-level), so application code that targets [Irmin.X] in Irmin 3 can switch to [Irmin_lwt.X] with no other change. The .ml ties everything together: - [module Maker (CA) (AW) = struct ... module Make (S) = Maker_v2.Make (CA) (AW) (S) end] - [module KV_maker = Maker.Make o Schema.KV] - [Of_storage] using the Maker chain - [module Lwt_to_eio] / [module Wrap_store] re-exposed for downstream backend packages - [type remote = Remote.t = ..] - [module Sync] re-exposed - Closed alias re-exposed [Of_backend] and the [Generic_key.Maker] functor are intentionally *not* exposed -- see the documentation paragraphs in the .mli and [LIMITATIONS.md] (added in a later commit). Adds the [src/irmin-lwt/core/dune] file declaring the [irmin_lwt] library. --- src/irmin-lwt/core/dune | 26 +- src/irmin-lwt/core/irmin_lwt.ml | 138 ++++++++ src/irmin-lwt/core/irmin_lwt.mli | 542 +++++++++++++++++++++++++++++++ 3 files changed, 686 insertions(+), 20 deletions(-) create mode 100644 src/irmin-lwt/core/irmin_lwt.ml create mode 100644 src/irmin-lwt/core/irmin_lwt.mli diff --git a/src/irmin-lwt/core/dune b/src/irmin-lwt/core/dune index 938a2ff5ec..eba49f725b 100644 --- a/src/irmin-lwt/core/dune +++ b/src/irmin-lwt/core/dune @@ -1,22 +1,8 @@ (library - (name irmin) - (public_name irmin) - (libraries - irmin.data - astring - bheap - digestif - fmt - jsonm - logs - logs.fmt - lwt - mtime - ocamlgraph - uri - uutf - (re_export repr)) + (name irmin_lwt) + (public_name irmin-lwt) + (libraries irmin lwt lwt_eio) + (flags + (:standard -w -69)) (preprocess - (pps ppx_irmin.internal -- --lib "Type")) - (instrumentation - (backend bisect_ppx))) + (pps ppx_irmin.internal -- --lib "Type"))) 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. *) From b8a11c341bb7922a9092bacd3278f4c56e0e1d5c Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:07:22 +0200 Subject: [PATCH 12/26] irmin-lwt-test: import Irmin 3 test harness verbatim from main Imports [main:src/irmin-test/] into [src/irmin-lwt/test/] unchanged. The harness consumes a Lwt-typed [Irmin.S] / [Irmin.KV] and runs the standard Irmin test suite (Generic_key tests, store tests, watch tests, branch tests, etc.). Each file is byte-identical to its main:src/irmin-test source. The next commit adapts it to consume [Irmin_lwt] in place of [Irmin] and reformats it under the project's ocamlformat 0.29.0. --- src/irmin-lwt/test/common.ml | 330 ++++ src/irmin-lwt/test/helpers.ml | 19 + src/irmin-lwt/test/import.ml | 18 + src/irmin-lwt/test/irmin_test.ml | 20 + src/irmin-lwt/test/irmin_test.mli | 74 + src/irmin-lwt/test/node.ml | 150 ++ src/irmin-lwt/test/store.ml | 2494 ++++++++++++++++++++++++++++ src/irmin-lwt/test/store.mli | 24 + src/irmin-lwt/test/store_graph.ml | 209 +++ src/irmin-lwt/test/store_graph.mli | 17 + src/irmin-lwt/test/store_watch.ml | 379 +++++ src/irmin-lwt/test/store_watch.mli | 17 + 12 files changed, 3751 insertions(+) create mode 100644 src/irmin-lwt/test/common.ml create mode 100644 src/irmin-lwt/test/helpers.ml create mode 100644 src/irmin-lwt/test/import.ml create mode 100644 src/irmin-lwt/test/irmin_test.ml create mode 100644 src/irmin-lwt/test/irmin_test.mli create mode 100644 src/irmin-lwt/test/node.ml create mode 100644 src/irmin-lwt/test/store.ml create mode 100644 src/irmin-lwt/test/store.mli create mode 100644 src/irmin-lwt/test/store_graph.ml create mode 100644 src/irmin-lwt/test/store_graph.mli create mode 100644 src/irmin-lwt/test/store_watch.ml create mode 100644 src/irmin-lwt/test/store_watch.mli diff --git a/src/irmin-lwt/test/common.ml b/src/irmin-lwt/test/common.ml new file mode 100644 index 0000000000..b6f59d37b9 --- /dev/null +++ b/src/irmin-lwt/test/common.ml @@ -0,0 +1,330 @@ +(* + * 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 + +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.Type.of_string (Conf.ty 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/helpers.ml b/src/irmin-lwt/test/helpers.ml new file mode 100644 index 0000000000..c2593ec7a6 --- /dev/null +++ b/src/irmin-lwt/test/helpers.ml @@ -0,0 +1,19 @@ +(* + * 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. + *) + +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..71053e21ba --- /dev/null +++ b/src/irmin-lwt/test/import.ml @@ -0,0 +1,18 @@ +(* + * 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 Irmin.Export_for_backends 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..52fa646d48 --- /dev/null +++ b/src/irmin-lwt/test/irmin_test.mli @@ -0,0 +1,74 @@ +(* + * 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 = 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..545f01f089 --- /dev/null +++ b/src/irmin-lwt/test/node.ml @@ -0,0 +1,150 @@ +(* + * 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. + *) + +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..ce6b5204dd --- /dev/null +++ b/src/irmin-lwt/test/store.ml @@ -0,0 +1,2494 @@ +(* + * 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 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..2d576ea5d6 --- /dev/null +++ b/src/irmin-lwt/test/store_graph.ml @@ -0,0 +1,209 @@ +(* + * 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 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..5b19ebed0d --- /dev/null +++ b/src/irmin-lwt/test/store_watch.ml @@ -0,0 +1,379 @@ +(* + * 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 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 From bebde7f97bb3d24fb4bcc4479871fe696f53ca5c Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:07:35 +0200 Subject: [PATCH 13/26] irmin-lwt-test: adapt harness to Irmin_lwt + reformat Three substantive patches (~120 lines effective across ~3700 lines): - [test/helpers.ml]: [module Irmin = Irmin_lwt] (replaces the [Irmin] reference in the harness with the shim's surface). - [test/import.ml]: add [include Lwt.Syntax] and [( >>= )] / [( >|= )] aliases used elsewhere in the harness. - [test/common.ml]: replace one call site that used [Irmin.Type.of_string (Conf.ty k)] with [Conf.of_string k] (the [Conf.ty] entry point exists on main but not on Irmin 4 -- the new [Conf] surface exposes [of_string] on each key directly, with the same semantics). Plus the dune file for the [irmin-lwt-test] library and an ocamlformat 0.29.0 reformat of the imported files. --- src/irmin-lwt/test/common.ml | 6 +- src/irmin-lwt/test/dune | 16 +++++ src/irmin-lwt/test/helpers.ml | 2 + src/irmin-lwt/test/import.ml | 5 ++ src/irmin-lwt/test/irmin_test.mli | 2 + src/irmin-lwt/test/node.ml | 6 +- src/irmin-lwt/test/store.ml | 99 ++++++++++++++++--------------- src/irmin-lwt/test/store_graph.ml | 1 + src/irmin-lwt/test/store_watch.ml | 1 + 9 files changed, 87 insertions(+), 51 deletions(-) create mode 100644 src/irmin-lwt/test/dune diff --git a/src/irmin-lwt/test/common.ml b/src/irmin-lwt/test/common.ml index b6f59d37b9..519a9453f0 100644 --- a/src/irmin-lwt/test/common.ml +++ b/src/irmin-lwt/test/common.ml @@ -14,6 +14,7 @@ * 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) @@ -230,7 +231,10 @@ module Make_helpers (S : Generic_key) = struct | Some v -> v ^ "_" ^ id in let v = - Irmin.Type.of_string (Conf.ty k) root_value |> Result.get_ok + (* 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 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 index c2593ec7a6..0e7edddff0 100644 --- a/src/irmin-lwt/test/helpers.ml +++ b/src/irmin-lwt/test/helpers.ml @@ -14,6 +14,8 @@ * 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 index 71053e21ba..c531843b5e 100644 --- a/src/irmin-lwt/test/import.ml +++ b/src/irmin-lwt/test/import.ml @@ -15,4 +15,9 @@ * 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.mli b/src/irmin-lwt/test/irmin_test.mli index 52fa646d48..b1a9872a87 100644 --- a/src/irmin-lwt/test/irmin_test.mli +++ b/src/irmin-lwt/test/irmin_test.mli @@ -14,6 +14,8 @@ * 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 diff --git a/src/irmin-lwt/test/node.ml b/src/irmin-lwt/test/node.ml index 545f01f089..5c2a366457 100644 --- a/src/irmin-lwt/test/node.ml +++ b/src/irmin-lwt/test/node.ml @@ -14,6 +14,8 @@ * 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)) @@ -68,8 +70,8 @@ module Suite (Map : Map) = struct 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)) + check __POS__ [%typ: Map.data option] ~expected:(Some v) + (Map.find node k)) let test_equal () = let module Map = struct diff --git a/src/irmin-lwt/test/store.ml b/src/irmin-lwt/test/store.ml index ce6b5204dd..33bb6d34ef 100644 --- a/src/irmin-lwt/test/store.ml +++ b/src/irmin-lwt/test/store.ml @@ -14,6 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +module Irmin = Irmin_lwt open! Import open Common @@ -1238,13 +1239,13 @@ module Make (S : Generic_key) = struct 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"); - ]) + [ + ("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 @@ -1790,46 +1791,48 @@ module Make (S : Generic_key) = struct 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")) + | `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 @@ -2357,7 +2360,7 @@ module Make (S : Generic_key) = struct let* node_b = S.Tree.destruct tree - |> (function `Contents _ -> assert false | `Node n -> n) + |> ( 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 diff --git a/src/irmin-lwt/test/store_graph.ml b/src/irmin-lwt/test/store_graph.ml index 2d576ea5d6..c1b1c5b6d1 100644 --- a/src/irmin-lwt/test/store_graph.ml +++ b/src/irmin-lwt/test/store_graph.ml @@ -14,6 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +module Irmin = Irmin_lwt open! Import open Common diff --git a/src/irmin-lwt/test/store_watch.ml b/src/irmin-lwt/test/store_watch.ml index 5b19ebed0d..b733d98e9c 100644 --- a/src/irmin-lwt/test/store_watch.ml +++ b/src/irmin-lwt/test/store_watch.ml @@ -14,6 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +module Irmin = Irmin_lwt open! Import open Common From a34b30decf4ab0e483e4dadb14dcc134dc894668 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:07:56 +0200 Subject: [PATCH 14/26] irmin-lwt-mem: in-memory backend Wraps [Irmin_mem]'s Append_only / Content_addressable / Atomic_write Makers, each operation forwarded through [Lwt_eio.run_eio]. Plugs the Lwt-typed Makers into [Irmin_lwt.Maker] and [Irmin_lwt.KV_maker]. Smoke test exercises: basic set/get, branches and commits, sync between two repos, [S.E] [Remote.t] constructor type-check, [Dot] output, and the full [irmin-lwt-test] harness on top (29/29 tests). --- src/irmin-lwt/mem/dune | 4 + src/irmin-lwt/mem/irmin_lwt_mem.ml | 102 ++++++++++++++++++++ src/irmin-lwt/mem/irmin_lwt_mem.mli | 47 ++++++++++ test/irmin-lwt-mem/dune | 12 +++ test/irmin-lwt-mem/test.ml | 139 ++++++++++++++++++++++++++++ test/irmin-lwt-mem/test_mem.ml | 24 +++++ 6 files changed, 328 insertions(+) create mode 100644 src/irmin-lwt/mem/dune create mode 100644 src/irmin-lwt/mem/irmin_lwt_mem.ml create mode 100644 src/irmin-lwt/mem/irmin_lwt_mem.mli create mode 100644 test/irmin-lwt-mem/dune create mode 100644 test/irmin-lwt-mem/test.ml create mode 100644 test/irmin-lwt-mem/test_mem.ml 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/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 () From 6a1c6ee3ea1114ca0fcdd59fbf7f0303599466ba Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:08:23 +0200 Subject: [PATCH 15/26] irmin-lwt-pack: on-disk pack backend A Lwt shim over [Irmin_pack_unix]. The user's Lwt-typed [Schema.S] is bridged to [Irmin.Schema.Extended] via [Lwt_to_eio.Schema_extended], the inner Eio store is built with [Irmin_pack_unix.Maker (Config).Make], and the result is re-wrapped to a Lwt-typed [Generic_key.S] via [Wrap_store.Make]. [Maker.Make]'s output extends [Generic_key.S] with the irmin-pack-unix specific surface, each Eio-direct effectful operation wrapped in [Lwt.t] via [Lwt_eio.run_eio]: - Integrity checks ([integrity_check], [integrity_check_inodes], [traverse_pack_file], [test_traverse_pack_file]). - Chunking / lower / on-disk ([split], [is_split_allowed], [add_volume], [reload], [flush], [create_one_commit_store]). - Statistics ([stats]). - Garbage collection ([Gc.start_exn], [finalise_exn], [run] (with [?finished] callback bridged), [wait], [cancel], [is_finished], [behaviour], [is_allowed], [latest_gc_target]). - Snapshots ([Snapshot.export] (with callback bridged), [Snapshot.Import.{v, save_elt, close}], plus the pure data types re-exported as type-equal to [Inner.Snapshot.*]). A few entry points unavoidably leak Eio types because they take Eio capabilities ([_ Eio.Domain_manager.t] for [Gc.start_exn] / [Gc.run] / [create_one_commit_store]; [Eio.Fs.dir_ty Eio.Path.t] for [create_one_commit_store] / [Snapshot.export ?on_disk]); Lwt callers must obtain these from their [Eio_main.run] runner. Smoke test on a temporary directory: basic set/get, branch and commit, persistence across reopen, plus the advanced surface ([flush], [integrity_check], [is_split_allowed], [Gc.is_allowed], [Gc.is_finished], [stats]). [Gc.run] is not exercised by the smoke test (would need a live [Eio.Domain_manager.t] and a non-trivial repo state). --- src/irmin-lwt/pack/dune | 11 ++ src/irmin-lwt/pack/irmin_lwt_pack.ml | 143 +++++++++++++++++++++ src/irmin-lwt/pack/irmin_lwt_pack.mli | 177 ++++++++++++++++++++++++++ test/irmin-lwt-pack/dune | 11 ++ test/irmin-lwt-pack/test.ml | 146 +++++++++++++++++++++ 5 files changed, 488 insertions(+) create mode 100644 src/irmin-lwt/pack/dune create mode 100644 src/irmin-lwt/pack/irmin_lwt_pack.ml create mode 100644 src/irmin-lwt/pack/irmin_lwt_pack.mli create mode 100644 test/irmin-lwt-pack/dune create mode 100644 test/irmin-lwt-pack/test.ml 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/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" From efcab2711333f3839fd1430eee126180df7da279 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:08:54 +0200 Subject: [PATCH 16/26] irmin-lwt-fs: filesystem (Unix) backend A Lwt-flavoured shim over [Irmin_fs_unix], mirroring the [irmin-lwt-mem] structure. Each Eio-direct operation in the Append_only and Atomic_write Makers is wrapped through [Lwt_eio.run_eio]; Content_addressable is derived from Append_only via [Irmin_lwt.Content_addressable.Make]; the result is plugged into [Irmin_lwt.Maker / KV_maker]. [config ~root ~clock] takes Eio types ([_ Eio.Path.t] and [_ Eio.Time.clock]) directly: the shim does not hide Eio in this entry point. Lwt callers obtain these from their [Eio_main.run] runner (typically [Eio.Stdenv.fs env] and [env#clock]). Smoke test on a temporary directory: basic set/get, branch and commit, persistence across reopen. --- src/irmin-lwt/fs/dune | 4 ++ src/irmin-lwt/fs/irmin_lwt_fs.ml | 79 +++++++++++++++++++++++ src/irmin-lwt/fs/irmin_lwt_fs.mli | 52 +++++++++++++++ test/irmin-lwt-fs/dune | 3 + test/irmin-lwt-fs/test.ml | 102 ++++++++++++++++++++++++++++++ 5 files changed, 240 insertions(+) create mode 100644 src/irmin-lwt/fs/dune create mode 100644 src/irmin-lwt/fs/irmin_lwt_fs.ml create mode 100644 src/irmin-lwt/fs/irmin_lwt_fs.mli create mode 100644 test/irmin-lwt-fs/dune create mode 100644 test/irmin-lwt-fs/test.ml 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/test/irmin-lwt-fs/dune b/test/irmin-lwt-fs/dune new file mode 100644 index 0000000000..b353f2cca4 --- /dev/null +++ b/test/irmin-lwt-fs/dune @@ -0,0 +1,3 @@ +(test + (name test) + (libraries irmin irmin-lwt irmin-lwt-fs 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..4820c739c1 --- /dev/null +++ b/test/irmin-lwt-fs/test.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. + *) + +(** 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) + +let () = + Eio_main.run @@ fun env -> + 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 "irmin-lwt-fs: all smoke tests passed" From 57cbe88d416b8766efbb0117506232c53b41d02d Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:08:54 +0200 Subject: [PATCH 17/26] irmin-lwt-chunk: chunking meta-backend A Lwt-flavoured shim over [Irmin_chunk.Content_addressable], the meta-backend that stores values cut into fixed-size chunks on top of an [Append_only.Maker]. The functor takes a Lwt-typed [Irmin_lwt.Append_only.Maker], lifts it to its Eio counterpart through [Lwt_to_eio.Append_only], runs it through [Irmin_chunk.Content_addressable] to obtain an Eio [Irmin.Content_addressable.Maker], and bridges each operation back to Lwt via [Lwt_eio.run_eio]. [Irmin_chunk.Conf] and [config] are re-exported transparently. Smoke test combines chunking with [Irmin_lwt_mem]'s Append_only and Atomic_write to build a chunked KV store; writes a small (3-byte) and a large (5000-byte, above the chunk threshold) value, reads both back. --- src/irmin-lwt/chunk/dune | 4 ++ src/irmin-lwt/chunk/irmin_lwt_chunk.ml | 56 +++++++++++++++++++++++ src/irmin-lwt/chunk/irmin_lwt_chunk.mli | 40 +++++++++++++++++ test/irmin-lwt-chunk/dune | 11 +++++ test/irmin-lwt-chunk/test.ml | 59 +++++++++++++++++++++++++ 5 files changed, 170 insertions(+) create mode 100644 src/irmin-lwt/chunk/dune create mode 100644 src/irmin-lwt/chunk/irmin_lwt_chunk.ml create mode 100644 src/irmin-lwt/chunk/irmin_lwt_chunk.mli create mode 100644 test/irmin-lwt-chunk/dune create mode 100644 test/irmin-lwt-chunk/test.ml 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/test/irmin-lwt-chunk/dune b/test/irmin-lwt-chunk/dune new file mode 100644 index 0000000000..d8d15e276f --- /dev/null +++ b/test/irmin-lwt-chunk/dune @@ -0,0 +1,11 @@ +(test + (name test) + (libraries + irmin + irmin-lwt + irmin-lwt-chunk + irmin-lwt-mem + 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..910b926b34 --- /dev/null +++ b/test/irmin-lwt-chunk/test.ml @@ -0,0 +1,59 @@ +(* + * 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 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) +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 -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + run "chunked set/get small+big" test_basic; + print_endline "irmin-lwt-chunk: smoke test passed" From ea009d1ffc8b96923fcf6f7e16fc36d467d3fe1c Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:08:54 +0200 Subject: [PATCH 18/26] irmin-lwt-containers: mergeable data structures Lwt-flavoured port of [irmin-containers] for [irmin-lwt]. Each data structure is re-implemented on top of [Irmin_lwt]'s Lwt-typed Store API; the merge logic is reused from the Eio side ([Irmin.Merge.counter] for the counter; [Irmin.Merge.option (v t merge_eio)] for time-stamped values) and bridged to a [Merge.t] via [Irmin_lwt.Lwt_to_eio.merge_of_eio]. Modules: - [Counter] -- int64 counter with inc / dec / read. - [Lww_register] -- last-writer-wins register parameterised by a [Time.S] and a value type. - [Blob_log] -- append-only log of timestamped values. Each module exposes [.Make (Backend : Irmin_lwt.KV_maker)], plus [.FS] / [.Mem] instantiations on top of [Irmin_lwt_fs.KV] / [Irmin_lwt_mem.KV]. [Linked_log] from [irmin-containers] is not ported: its merge function performs reads on a content-addressable handle, and bridging that to Lwt would require threading a Lwt-typed CAS handle through the merge. Skipped for now. --- src/irmin-lwt/containers/dune | 14 ++ .../containers/irmin_lwt_containers.ml | 232 ++++++++++++++++++ test/irmin-lwt-containers/dune | 13 + test/irmin-lwt-containers/test.ml | 74 ++++++ 4 files changed, 333 insertions(+) create mode 100644 src/irmin-lwt/containers/dune create mode 100644 src/irmin-lwt/containers/irmin_lwt_containers.ml create mode 100644 test/irmin-lwt-containers/dune create mode 100644 test/irmin-lwt-containers/test.ml 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/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" From 2535d1abfbed9deb98452cfffe24159dc622c659 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:09:30 +0200 Subject: [PATCH 19/26] irmin-lwt-git: Git backend A Lwt shim over [Irmin_git_unix]. The user provides a Lwt-typed [Contents.S]; the shim bridges it to Eio via [Lwt_to_eio.Contents], applies the git Maker, and wraps the resulting Eio store back to a Lwt-typed [Generic_key.S] via [Wrap_store.Make]. Git-specific extras ([module Git], [git_commit], [git_of_repo], [repo_of_git], [remote]) are passed through unchanged. The Lwt-side [Schema] reuses [Inner.Schema]'s pure modules (Hash, Branch, Info, Path) directly because their module types have no [Lwt.t] in either the Lwt or the Eio module type definitions. Only [Metadata] needs a Lwt-bridged [merge]. Exposes: - [Maker (G : Irmin_git.G)] producing [KV] / [Ref] convenience instantiations for any ocaml-git store. - [Mem] = [Maker (Irmin_git.Mem)] -- in-memory git store. - [FS] = [Maker (Git_unix.Store)] -- on-disk git store. Smoke test on Mem: basic set/get, branch and commit, [git_commit] passthrough verifying the underlying ocaml-git commit object is retrievable from a commit handle. --- src/irmin-lwt/git/dune | 4 + src/irmin-lwt/git/irmin_lwt_git.ml | 115 +++++++++++++++++++++++++++++ test/irmin-lwt-git/dune | 11 +++ test/irmin-lwt-git/test.ml | 79 ++++++++++++++++++++ 4 files changed, 209 insertions(+) create mode 100644 src/irmin-lwt/git/dune create mode 100644 src/irmin-lwt/git/irmin_lwt_git.ml create mode 100644 test/irmin-lwt-git/dune create mode 100644 test/irmin-lwt-git/test.ml 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/test/irmin-lwt-git/dune b/test/irmin-lwt-git/dune new file mode 100644 index 0000000000..3f47b6d1b2 --- /dev/null +++ b/test/irmin-lwt-git/dune @@ -0,0 +1,11 @@ +(test + (name test) + (libraries + irmin + irmin-lwt + irmin-lwt-git + irmin-git + 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..2cc869ed88 --- /dev/null +++ b/test/irmin-lwt-git/test.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. + *) + +(** 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) +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 -> + 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 "irmin-lwt-git: all smoke tests passed" From 4760209f0c5868ec8b1290b894182316da2ad860 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:09:30 +0200 Subject: [PATCH 20/26] irmin-lwt-client: RPC client for irmin-server A Lwt shim over [Irmin_client_unix]. The user provides only a Lwt-typed [Contents.S]; the shim synthesises an Eio reference store ([Irmin_mem.KV.Make (V_eio)]) purely as a Schema carrier (the local mem backend is never used since the client routes all ops over the wire), feeds it to [Irmin_client_unix.Make_codec], and wraps the result back to [Irmin_lwt.Generic_key.S] via [Wrap_store.Make]. Client extras ([connect], [reconnect], [dup], [Batch], [export], [import], etc.) are passed through, with Eio-direct ones wrapped in [Lwt.t] for caller convenience. Modules: - [Make_codec (Codec) (V)] -- Make parameterised by codec. - [Make (V)] -- default binary codec. - [Make_json (V)] -- JSON codec. - [config] / [Error] re-exported from [Irmin_client_unix]. Smoke test spawns an [Irmin_server_unix] in an Eio fiber on a Unix-domain socket, connects with the Lwt client, runs basic set / get / find. --- src/irmin-lwt/client/dune | 11 ++++ src/irmin-lwt/client/irmin_lwt_client.ml | 84 ++++++++++++++++++++++++ test/irmin-lwt-client/dune | 16 +++++ test/irmin-lwt-client/test.ml | 76 +++++++++++++++++++++ 4 files changed, 187 insertions(+) create mode 100644 src/irmin-lwt/client/dune create mode 100644 src/irmin-lwt/client/irmin_lwt_client.ml create mode 100644 test/irmin-lwt-client/dune create mode 100644 test/irmin-lwt-client/test.ml 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/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" From 4896dd683425d4c690b262d0a3e801ec2536a933 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:09:30 +0200 Subject: [PATCH 21/26] irmin-lwt-tezos: Tezos schema + Lwt-typed pack store A Lwt shim exposing the Tezos-specific Irmin schema (BLAKE2B + Base58 hash, V1 pre-hashing for Node / Commit / Contents) on top of [irmin-pack-unix], with a Lwt-typed Store API. Implementation trick: instead of going through [Irmin_lwt_pack.Maker (Conf).Make] -- which would replace the Tezos Schema's V1 pre-hashing with the default [Generic_key.Make] via the [Lwt_to_eio.Schema_extended] adapter -- the shim uses [Irmin_tezos.Schema] directly as [Schema_eio] in [Wrap_store.Make], constructing in parallel a Lwt-side [Schema_lwt] that reuses [Schema.Hash / Branch / Info / Path] (pure modules, satisfy both Lwt and Eio Schema.S constraints) and bridges [Schema.Metadata.merge] and [Schema.Contents.merge] via [Lwt_to_eio.merge_of_eio]. The V1 pre-hashing is preserved end-to-end, so on-disk data is wire- compatible with regular [irmin-tezos] data. Smoke test: write a [bytes] value to a fresh temporary pack store and read it back. --- src/irmin-lwt/tezos/dune | 13 +++++ src/irmin-lwt/tezos/irmin_lwt_tezos.ml | 69 ++++++++++++++++++++++++++ test/irmin-lwt-tezos/dune | 11 ++++ test/irmin-lwt-tezos/test.ml | 67 +++++++++++++++++++++++++ 4 files changed, 160 insertions(+) create mode 100644 src/irmin-lwt/tezos/dune create mode 100644 src/irmin-lwt/tezos/irmin_lwt_tezos.ml create mode 100644 test/irmin-lwt-tezos/dune create mode 100644 test/irmin-lwt-tezos/test.ml 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-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" From 41b759d79ac257b2f22228d746bf96921b88e396 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:12:46 +0200 Subject: [PATCH 22/26] irmin-lwt: documentation -- index, migration guide, LIMITATIONS Three documentation artefacts: - [doc/irmin-lwt/index.mld]: package landing page for irmin.org. Opens with a prominent warning that the main loop must be Eio (the central limitation of the shim: every operation goes through [Lwt_eio] and requires a running [Eio_main.run] scheduler at the top level). Lists each shim package with one usage example. - [doc/irmin-lwt/migration.mld]: step-by-step migration guide from Irmin 3 (Lwt) to Irmin 4 via the shim. Restructures the main loop, swaps opam deps, renames module references, adjusts the configurations that take Eio types directly, wires up the watch switch when needed, lists workarounds for the dropped entry points ([Of_backend], [Generic_key.Maker] functor). - [src/irmin-lwt/LIMITATIONS.md]: canonical list of what the shim does not support, with rationale for each entry ([Of_backend], [Generic_key.Maker] functor, [Watch.set_watch_switch] caveat, un-ported sister packages [graphql], [mirage], [cli], [server]). --- doc/irmin-lwt/dune | 3 + doc/irmin-lwt/index.mld | 242 +++++++++++++++++++++++++++++++++ doc/irmin-lwt/migration.mld | 251 +++++++++++++++++++++++++++++++++++ src/irmin-lwt/LIMITATIONS.md | 155 +++++++++++++++++++++ 4 files changed, 651 insertions(+) create mode 100644 doc/irmin-lwt/dune create mode 100644 doc/irmin-lwt/index.mld create mode 100644 doc/irmin-lwt/migration.mld create mode 100644 src/irmin-lwt/LIMITATIONS.md 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/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. From 8994804da0898e704b74472129a53dcdbcdadb9e Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:12:46 +0200 Subject: [PATCH 23/26] CHANGES: irmin-lwt entry --- CHANGES.md | 7 +++++++ 1 file changed, 7 insertions(+) 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) From 0b44ecc9496f7239d4f278a6ae0d66d8cf74f5b5 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:51:48 +0200 Subject: [PATCH 24/26] irmin-lwt-fs: wire the irmin-lwt-test harness (28/28 tests) Adds a [Irmin_lwt_test.Irmin_test.Suite] for [Irmin_lwt_fs] alongside the existing smoke tests. The full Irmin test suite (basic, branches, nodes, commits, slices, sync, watch, ...) runs against the filesystem backend and passes 28/28. Filesystem watching needs a [listen_dir_hook]; we bridge [Irmin_watcher.hook] (Lwt-typed) to [Irmin.Backend.Watch.hook] (Eio direct-style) and register it before [Lwt_eio.with_event_loop]. --- test/irmin-lwt-fs/dune | 11 ++++++++++- test/irmin-lwt-fs/test.ml | 30 +++++++++++++++++++++++++++++- 2 files changed, 39 insertions(+), 2 deletions(-) diff --git a/test/irmin-lwt-fs/dune b/test/irmin-lwt-fs/dune index b353f2cca4..49ee711829 100644 --- a/test/irmin-lwt-fs/dune +++ b/test/irmin-lwt-fs/dune @@ -1,3 +1,12 @@ (test (name test) - (libraries irmin irmin-lwt irmin-lwt-fs lwt lwt_eio eio_main unix)) + (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 index 4820c739c1..a700f6f377 100644 --- a/test/irmin-lwt-fs/test.ml +++ b/test/irmin-lwt-fs/test.ml @@ -87,8 +87,31 @@ let with_tmp_dir env f = 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 = @@ -99,4 +122,9 @@ let () = 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 "irmin-lwt-fs: all smoke tests passed" + 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" From 6e18d356c0fe94517f8cc91bdf8ccf3367e55b74 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:51:48 +0200 Subject: [PATCH 25/26] irmin-lwt-chunk: wire the irmin-lwt-test harness (29/29 tests) Combines [Irmin_lwt_chunk.Content_addressable (Irmin_lwt_mem.Append_only)] with [Irmin_lwt_mem.Atomic_write] to obtain a full [Irmin_lwt.Maker], and runs the harness on it: 29/29 tests pass. --- test/irmin-lwt-chunk/dune | 1 + test/irmin-lwt-chunk/test.ml | 22 ++++++++++++++++++++-- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/test/irmin-lwt-chunk/dune b/test/irmin-lwt-chunk/dune index d8d15e276f..42430432da 100644 --- a/test/irmin-lwt-chunk/dune +++ b/test/irmin-lwt-chunk/dune @@ -5,6 +5,7 @@ irmin-lwt irmin-lwt-chunk irmin-lwt-mem + irmin-lwt-test lwt lwt_eio eio_main diff --git a/test/irmin-lwt-chunk/test.ml b/test/irmin-lwt-chunk/test.ml index 910b926b34..8b40dd9421 100644 --- a/test/irmin-lwt-chunk/test.ml +++ b/test/irmin-lwt-chunk/test.ml @@ -22,9 +22,10 @@ the default chunk size threshold. *) module CA = Irmin_lwt_chunk.Content_addressable (Irmin_lwt_mem.Append_only) -module Maker = Irmin_lwt.Maker (CA) (Irmin_lwt_mem.Atomic_write) +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 = @@ -54,6 +55,23 @@ let run name f = 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 "irmin-lwt-chunk: smoke test passed" + 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" From 6d507e184e8545d0f04e3facbaf94a7cbbf094c9 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Wed, 6 May 2026 17:51:48 +0200 Subject: [PATCH 26/26] irmin-lwt-git: wire the irmin-lwt-test harness on the Mem variant (28/28 tests) [Irmin_lwt_git.Mem.KV] satisfies [Irmin_test.Generic_key]; running the harness on it gives 28/28 tests passing (one less than mem because Git has no [Metadata.None] -- the suite skips one test). --- test/irmin-lwt-git/dune | 1 + test/irmin-lwt-git/test.ml | 17 ++++++++++++++++- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/test/irmin-lwt-git/dune b/test/irmin-lwt-git/dune index 3f47b6d1b2..38fae714f5 100644 --- a/test/irmin-lwt-git/dune +++ b/test/irmin-lwt-git/dune @@ -5,6 +5,7 @@ irmin-lwt irmin-lwt-git irmin-git + irmin-lwt-test lwt lwt_eio eio_main diff --git a/test/irmin-lwt-git/test.ml b/test/irmin-lwt-git/test.ml index 2cc869ed88..30b4576ec3 100644 --- a/test/irmin-lwt-git/test.ml +++ b/test/irmin-lwt-git/test.ml @@ -20,6 +20,7 @@ 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 = @@ -72,8 +73,22 @@ let run name f = 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 "irmin-lwt-git: all smoke tests passed" + 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"