irmin-pack: move sigs to unix

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

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

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

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

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

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 ]

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

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

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 = {

src/irmin-pack/s.ml → 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 ->

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

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)