diff --git a/CHANGES.md b/CHANGES.md index 93534832bf..631647b92c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,6 +8,12 @@ - **irmin-graphql** - Expose `test_set_and_get` function as a new mutation (#2075, @patricoferris) +### Changed + +- **irmin-pack** + - `irmin_pack_mem` no longer exposes disk specifics functions (#2081, + @icristescu) + ## 3.4.1 (2022-09-07) ### Added diff --git a/bench/irmin-pack/tree.ml b/bench/irmin-pack/tree.ml index a44f05ea40..f14d6ed437 100644 --- a/bench/irmin-pack/tree.ml +++ b/bench/irmin-pack/tree.ml @@ -205,14 +205,50 @@ module Bench_suite (Store : Store) = struct ([ "" ], [ summary ])) end -module Make_basic (Maker : functor (_ : Irmin_pack.Conf.S) -> - Irmin_pack.Maker) -(Conf : Irmin_pack.Conf.S) = -struct +module Make_store_mem (Conf : Irmin_pack.Conf.S) = struct type store_config = config module Store = struct - open Maker (Conf) + open Irmin_pack_mem.Maker (Conf) + include Make (Irmin_tezos.Schema) + end + + include Store + + type key = commit_key + + let indexing_strategy = Irmin_pack.Indexing_strategy.minimal + + let create_repo ~root _config = + let conf = + Irmin_pack.config ~readonly:false ~fresh:true ~indexing_strategy root + in + prepare_artefacts_dir root; + let* repo = Store.Repo.v conf in + let on_commit _ _ = Lwt.return_unit in + let on_end () = Lwt.return_unit in + Lwt.return (repo, on_commit, on_end) + + let gc_wait _repo = Lwt.return_unit + + type gc_stats = { + duration : float; + finalisation_duration : float; + read_gc_output_duration : float; + transfer_latest_newies_duration : float; + swap_duration : float; + unlink_duration : float; + } + [@@deriving irmin] + + let gc_run ?finished:_ _repo _key = Lwt.return_unit +end + +module Make_store_pack (Conf : Irmin_pack.Conf.S) = struct + type store_config = config + + module Store = struct + open Irmin_pack_unix.Maker (Conf) include Make (Irmin_tezos.Schema) end @@ -259,9 +295,6 @@ struct | Error (`Msg err) -> failwith err end -module Make_store_mem = Make_basic (Irmin_pack_mem.Maker) -module Make_store_pack = Make_basic (Irmin_pack_unix.Maker) - module type B = sig val run_large : config -> (Format.formatter -> unit) Lwt.t val run_chains : config -> (Format.formatter -> unit) Lwt.t diff --git a/src/irmin-pack/irmin_pack.ml b/src/irmin-pack/irmin_pack.ml index ab774fd921..59dde7fda7 100644 --- a/src/irmin-pack/irmin_pack.ml +++ b/src/irmin-pack/irmin_pack.ml @@ -18,8 +18,6 @@ include Irmin_pack_intf let config = Conf.init -exception RO_not_allowed = S.RO_not_allowed - module Indexing_strategy = Indexing_strategy module Indexable = Indexable module Atomic_write = Atomic_write @@ -33,4 +31,3 @@ module Layout = Layout module Inode = Inode module Pack_key = Pack_key module Pack_value = Pack_value -module S = S diff --git a/src/irmin-pack/irmin_pack_intf.ml b/src/irmin-pack/irmin_pack_intf.ml index 575e11bff4..91d1d92dde 100644 --- a/src/irmin-pack/irmin_pack_intf.ml +++ b/src/irmin-pack/irmin_pack_intf.ml @@ -13,11 +13,51 @@ * 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 = S.S -module type Specifics = S.Specifics -module type Maker = S.Maker -module type Maker_persistent = S.Maker_persistent +exception RO_not_allowed + +module type Checkable = sig + type 'a t + type hash + + val integrity_check : + offset:int63 -> + length:int -> + hash -> + _ t -> + (unit, [ `Wrong_hash | `Absent_value ]) result +end + +module type S = Irmin.Generic_key.S + +module S_is_a_store (X : S) : Irmin.Generic_key.S = X + +module type Maker = sig + type endpoint = unit + + include Irmin.Key.Store_spec.S + + module Make (Schema : Irmin.Schema.Extended) : + S + (* We can't have `with module Schema = Schema` here, since the Schema + on the RHS contains more information than the one on the LHS. We _want_ + to do something like `with module Schema = (Schema : Irmin.Schema.S)`, + but this isn't supported. + + TODO: extract these extensions as a separate functor argument instead. *) + with type Schema.Hash.t = Schema.Hash.t + and type Schema.Branch.t = Schema.Branch.t + and type Schema.Metadata.t = Schema.Metadata.t + and type Schema.Path.t = Schema.Path.t + and type Schema.Path.step = Schema.Path.step + and type Schema.Contents.t = Schema.Contents.t + and type Schema.Info.t = Schema.Info.t + 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 + and type Backend.Remote.endpoint = endpoint +end module type Sigs = sig module Conf = Conf @@ -44,14 +84,12 @@ module type Sigs = sig exception RO_not_allowed module type S = S - module type Specifics = Specifics module type Maker = Maker - module type Maker_persistent = Maker_persistent + module type Checkable = Checkable module Stats = Stats module Layout = Layout module Indexable = Indexable module Atomic_write = Atomic_write module Version = Version - module S = S end diff --git a/src/irmin-pack/mem/irmin_pack_mem.ml b/src/irmin-pack/mem/irmin_pack_mem.ml index 32211d570c..608a35fa1d 100644 --- a/src/irmin-pack/mem/irmin_pack_mem.ml +++ b/src/irmin-pack/mem/irmin_pack_mem.ml @@ -162,76 +162,9 @@ module Maker (Config : Irmin_pack.Conf.S) = struct Node.Indexable.close (snd (node_t t)) >>= fun () -> Commit.Indexable.close (snd (commit_t t)) >>= fun () -> Branch.close t.branch - - (* An in-memory store is always in reload. *) - let reload _ = () - let flush _ = () - - let start_gc ?unlink _ _ = - ignore unlink; - Lwt.return false - - let finalise_gc ?wait _ = - ignore wait; - Lwt.return `Idle end end include Irmin.Of_backend (X) - - module Snapshot = struct - include X.Node.Indexable.Inter.Snapshot - - type t = Inode of inode | Blob of Backend.Contents.Val.t - [@@deriving irmin] - - let export ?on_disk:_ _ _ ~root_key:_ = Fmt.failwith "not implemented" - - module Import = struct - type process = unit - - let v ?on_disk:_ _ = Fmt.failwith "not implemented" - let save_elt _ _ = Fmt.failwith "not implemented" - let close _ = Fmt.failwith "not implemented" - end - end - - module Gc = struct - type msg = [ `Msg of string ] - - type stats = { - duration : float; - finalisation_duration : float; - read_gc_output_duration : float; - transfer_latest_newies_duration : float; - swap_duration : float; - unlink_duration : float; - } - [@@deriving irmin] - - type process_state = [ `Idle | `Running | `Finalised of stats ] - - let start_exn = X.Repo.start_gc - let finalise_exn = X.Repo.finalise_gc - - let run ?finished _ _ = - ignore finished; - Lwt.return_ok false - - let wait _ = Lwt.return_ok None - let is_finished _ = true - let is_allowed _ = false - end - - let integrity_check_inodes ?heads:_ _ = - Lwt.return - (Error (`Msg "Not supported: integrity checking of in-memory inodes")) - - let reload = X.Repo.reload - let flush = X.Repo.flush - let integrity_check ?ppf:_ ~auto_repair:_ _t = Ok `No_error - let traverse_pack_file _ _ = () - let test_traverse_pack_file _ _ = () - let stats ~dump_blob_paths_to:_ ~commit:_ _ = Lwt.return_unit end end diff --git a/src/irmin-pack/unix/checks_intf.ml b/src/irmin-pack/unix/checks_intf.ml index d0b75e6e68..3404dd0070 100644 --- a/src/irmin-pack/unix/checks_intf.ml +++ b/src/irmin-pack/unix/checks_intf.ml @@ -106,7 +106,7 @@ end module type Store = sig include Irmin.S - include Irmin_pack.S with type repo := repo and type commit := commit + include S.S with type repo := repo and type commit := commit end type integrity_error = [ `Wrong_hash | `Absent_value ] diff --git a/src/irmin-pack/unix/inode_intf.ml b/src/irmin-pack/unix/inode_intf.ml index e5686f25b4..1ecbc61607 100644 --- a/src/irmin-pack/unix/inode_intf.ml +++ b/src/irmin-pack/unix/inode_intf.ml @@ -31,7 +31,7 @@ module type Persistent = sig dispatcher:dispatcher -> read t - include Irmin_pack.S.Checkable with type 'a t := 'a t and type hash := hash + include Irmin_pack.Checkable with type 'a t := 'a t and type hash := hash (* val reload : 'a t -> unit *) val integrity_check_inodes : [ `Read ] t -> key -> (unit, string) result Lwt.t diff --git a/src/irmin-pack/unix/irmin_pack_unix.ml b/src/irmin-pack/unix/irmin_pack_unix.ml index b3e6750cd4..4691bbbc87 100644 --- a/src/irmin-pack/unix/irmin_pack_unix.ml +++ b/src/irmin-pack/unix/irmin_pack_unix.ml @@ -34,6 +34,8 @@ module Maker = Ext.Maker module Mapping_file = Mapping_file module Utils = Utils +module type S = S.S + module KV (Config : Irmin_pack.Conf.S) = struct type endpoint = unit type hash = Irmin.Schema.default_hash diff --git a/src/irmin-pack/unix/pack_store_intf.ml b/src/irmin-pack/unix/pack_store_intf.ml index 664546af73..87ea21b1eb 100644 --- a/src/irmin-pack/unix/pack_store_intf.ml +++ b/src/irmin-pack/unix/pack_store_intf.ml @@ -38,7 +38,7 @@ module type S = sig val cast : read t -> read_write t (** @inline *) - include Irmin_pack.S.Checkable with type 'a t := 'a t and type hash := hash + include Irmin_pack.Checkable with type 'a t := 'a t and type hash := hash module Entry_prefix : sig type t = { diff --git a/src/irmin-pack/s.ml b/src/irmin-pack/unix/s.ml similarity index 95% rename from src/irmin-pack/s.ml rename to src/irmin-pack/unix/s.ml index 1a87491343..f5b53c2354 100644 --- a/src/irmin-pack/s.ml +++ b/src/irmin-pack/unix/s.ml @@ -16,24 +16,9 @@ open! Import -exception RO_not_allowed - -module type Checkable = sig - type 'a t - type hash - - val integrity_check : - offset:int63 -> - length:int -> - hash -> - _ t -> - (unit, [ `Wrong_hash | `Absent_value ]) result -end - -(** [Irmin-pack]-specific extensions to the [Store] module type. *) -module type Specifics = sig - type repo - type commit_key +(** [Irmin-pack-unix]-specific extensions to the [Store] module type. *) +module type S = sig + include Irmin.Generic_key.S val integrity_check : ?ppf:Format.formatter -> @@ -149,11 +134,6 @@ module type Specifics = sig val is_allowed : repo -> bool (** [is_allowed repo] returns true if a gc can be run on the store. *) end -end - -module type S = sig - include Irmin.Generic_key.S - include Specifics with type repo := repo and type commit_key := commit_key val integrity_check_inodes : ?heads:commit list -> diff --git a/src/irmin-tezos/irmin_tezos.mli b/src/irmin-tezos/irmin_tezos.mli index e12662bef4..197a4078d9 100644 --- a/src/irmin-tezos/irmin_tezos.mli +++ b/src/irmin-tezos/irmin_tezos.mli @@ -18,7 +18,7 @@ module Schema = Schema module Conf : Irmin_pack.Conf.S module Store : - Irmin_pack.S + Irmin_pack_unix.S with type Schema.Hash.t = Schema.Hash.t and type Schema.Branch.t = Schema.Branch.t and type Schema.Metadata.t = Schema.Metadata.t diff --git a/test/irmin-bench/replay.ml b/test/irmin-bench/replay.ml index a430864e59..102e38c72e 100644 --- a/test/irmin-bench/replay.ml +++ b/test/irmin-bench/replay.ml @@ -143,11 +143,9 @@ module Store_mem = struct let on_end () = Lwt.return_unit in Lwt.return (repo, on_commit, on_end) - let gc_wait repo = - let* r = Store.Gc.wait repo in - match r with Ok _ -> Lwt.return_unit | Error (`Msg err) -> failwith err + let gc_wait _repo = Lwt.return_unit - type gc_stats = Store.Gc.stats = { + type gc_stats = { duration : float; finalisation_duration : float; read_gc_output_duration : float; @@ -157,17 +155,7 @@ module Store_mem = struct } [@@deriving irmin] - let gc_run ?(finished = fun _ -> Lwt.return_unit) repo key = - let f (result : (Store.Gc.stats, Store.Gc.msg) result) = - match result with - | Error (`Msg err) -> finished @@ Error err - | Ok _ as s -> finished @@ s - in - let* launched = Store.Gc.run ~finished:f repo key in - match launched with - | Ok true -> Lwt.return_unit - | Ok false -> [%logs.app "GC skipped"] |> Lwt.return - | Error (`Msg err) -> failwith err + let gc_run ?finished:_ _repo _key = Lwt.return_unit end module Replay_mem = Irmin_traces.Trace_replay.Make (Store_mem)