irmin-pack: add lower_root config for lower layer

CHANGES.md

@@ -1,5 +1,11 @@
 ## Unreleased
 
+### Added
+
+- **irmin-pack**
+  - Add configuration option, `lower_root`, to specify a path for archiving data
+    during a GC. (#2177, @metanivek)
+
 ### Changed
 
 - **irmin-pack**

src/irmin-pack/conf.ml

@@ -38,6 +38,7 @@ module Default = struct
   let dict_auto_flush_threshold = 1_000_000
   let suffix_auto_flush_threshold = 1_000_000
   let no_migrate = false
+  let lower_root = None
 end
 
 open Irmin.Backend.Conf
@@ -70,6 +71,11 @@ module Key = struct
 
   let root = root spec
 
+  let lower_root =
+    key ~spec ~doc:"Optional path for lower layer directory." "lower-root"
+      Irmin.Type.(option string)
+      Default.lower_root
+
   let indexing_strategy =
     let serialisable_t = [%typ: [ `Always | `Minimal ]] in
     key ~spec ~doc:"Strategy to use for adding objects to the index"
@@ -115,6 +121,7 @@ let root config =
          the store"
   | Some root -> root
 
+let lower_root config = get config Key.lower_root
 let indexing_strategy config = get config Key.indexing_strategy
 let use_fsync config = get config Key.use_fsync
 let dict_auto_flush_threshold config = get config Key.dict_auto_flush_threshold
@@ -131,9 +138,10 @@ let init ?(fresh = Default.fresh) ?(readonly = Default.readonly)
     ?(use_fsync = Default.use_fsync)
     ?(dict_auto_flush_threshold = Default.dict_auto_flush_threshold)
     ?(suffix_auto_flush_threshold = Default.suffix_auto_flush_threshold)
-    ?(no_migrate = Default.no_migrate) root =
+    ?(no_migrate = Default.no_migrate) ?(lower_root = Default.lower_root) root =
   let config = empty spec in
   let config = add config Key.root root in
+  let config = add config Key.lower_root lower_root in
   let config = add config Key.fresh fresh in
   let config = add config Key.lru_size lru_size in
   let config = add config Key.index_log_size index_log_size in

src/irmin-pack/conf.mli

@@ -74,6 +74,7 @@ module Key : sig
   val index_log_size : int Irmin.Backend.Conf.key
   val readonly : bool Irmin.Backend.Conf.key
   val root : string Irmin.Backend.Conf.key
+  val lower_root : string option Irmin.Backend.Conf.key
   val merge_throttle : merge_throttle Irmin.Backend.Conf.key
   val indexing_strategy : Indexing_strategy.t Irmin.Backend.Conf.key
   val use_fsync : bool Irmin.Backend.Conf.key
@@ -105,6 +106,9 @@ val root : Irmin.Backend.Conf.t -> string
     Note: The path before the root directory must exist. Only the final
     directory in the path will be created if it is missing. *)
 
+val lower_root : Irmin.Backend.Conf.t -> string option
+(** Optional path for lower layer directory. Default [None]. *)
+
 val indexing_strategy : Irmin.Backend.Conf.t -> Indexing_strategy.t
 (** Strategy for choosing which objects to index. See {!Indexing_strategy.t} for
     more discussion. Default {!Indexing_strategy.default} *)
@@ -135,6 +139,7 @@ val init :
   ?dict_auto_flush_threshold:int ->
   ?suffix_auto_flush_threshold:int ->
   ?no_migrate:bool ->
+  ?lower_root:string option ->
   string ->
   Irmin.config
 (** [init root] creates a backend configuration for storing data with default

src/irmin-pack/irmin_pack_intf.ml

@@ -80,6 +80,7 @@ module type Sigs = sig
     ?dict_auto_flush_threshold:int ->
     ?suffix_auto_flush_threshold:int ->
     ?no_migrate:bool ->
+    ?lower_root:string option ->
     string ->
     Irmin.config
   (** Configuration options for stores. See {!Irmin_pack.Conf} for more details. *)

src/irmin-pack/unix/control_file_intf.ml

@@ -210,7 +210,7 @@ module type S = sig
   type open_error :=
     [ `Corrupted_control_file
     | `Io_misc of Io.misc_error
-    | `No_such_file_or_directory
+    | `No_such_file_or_directory of string
     | `Not_a_file
     | `Closed
     | `Unknown_major_pack_version of string ]

src/irmin-pack/unix/errors.ml

@@ -38,7 +38,7 @@ type base_error =
   [ `Double_close
   | `File_exists of string
   | `Invalid_parent_directory
-  | `No_such_file_or_directory
+  | `No_such_file_or_directory of string
   | `Not_a_file
   | `Read_out_of_bounds
   | `Invalid_argument

src/irmin-pack/unix/file_manager.ml

@@ -598,7 +598,7 @@ struct
     let no_migrate = Irmin_pack.Conf.no_migrate config in
     match Io.classify_path root with
     | `File | `Other -> Error (`Not_a_directory root)
-    | `No_such_file_or_directory -> Error `No_such_file_or_directory
+    | `No_such_file_or_directory -> Error (`No_such_file_or_directory root)
     | `Directory -> (
         let path = Irmin_pack.Layout.V4.control ~root in
         match Io.classify_path path with
@@ -621,11 +621,11 @@ struct
       Control.open_ ~readonly:true ~path
       (* If no control file, then check whether the store is in v1 or v2. *)
       |> Result.map_error (function
-           | `No_such_file_or_directory -> (
+           | `No_such_file_or_directory _ -> (
                let pack = Irmin_pack.Layout.V1_and_v2.pack ~root in
                match Io.classify_path pack with
                | `File -> `Migration_needed
-               | `No_such_file_or_directory -> `No_such_file_or_directory
+               | `No_such_file_or_directory -> `No_such_file_or_directory pack
                | `Directory | `Other -> `Invalid_layout)
            | error -> error)
     in
@@ -693,20 +693,20 @@ struct
       | Ok v -> Ok v
       | Error `Double_close | Error `Invalid_argument | Error `Closed ->
           assert false
-      | Error `No_such_file_or_directory -> Error `Invalid_layout
+      | Error (`No_such_file_or_directory _) -> Error `Invalid_layout
       | Error `Not_a_file -> Error `Invalid_layout
       | Error `Corrupted_legacy_file | Error `Read_out_of_bounds ->
           Error `Corrupted_legacy_file
       | Error (`Io_misc _) as e -> e
     in
     match Io.classify_path root with
-    | `No_such_file_or_directory -> Error `No_such_file_or_directory
+    | `No_such_file_or_directory -> Error (`No_such_file_or_directory root)
     | `File | `Other -> Error (`Not_a_directory root)
     | `Directory -> (
         let path = Irmin_pack.Layout.V4.control ~root in
         match Control.open_ ~path ~readonly:true with
         | Ok _ -> Ok `V3
-        | Error `No_such_file_or_directory -> v2_or_v1 ()
+        | Error (`No_such_file_or_directory _) -> v2_or_v1 ()
         | Error `Not_a_file -> Error `Invalid_layout
         | Error `Closed -> assert false
         | Error

src/irmin-pack/unix/file_manager_intf.ml

@@ -110,7 +110,7 @@ module type S = sig
     | `Invalid_layout
     | `Io_misc of Control.Io.misc_error
     | `Migration_needed
-    | `No_such_file_or_directory
+    | `No_such_file_or_directory of string
     | `Not_a_directory of string
     | `Not_a_file
     | `Read_out_of_bounds
@@ -148,7 +148,7 @@ module type S = sig
     | `Corrupted_mapping_file of string
     | `Io_misc of Io.misc_error
     | `Migration_needed
-    | `No_such_file_or_directory
+    | `No_such_file_or_directory of string
     | `Not_a_file
     | `Closed
     | `V3_store_from_the_future
@@ -227,7 +227,7 @@ module type S = sig
     | `Corrupted_legacy_file
     | `Invalid_layout
     | `Io_misc of Io.misc_error
-    | `No_such_file_or_directory
+    | `No_such_file_or_directory of string
     | `Not_a_directory of string
     | `Unknown_major_pack_version of string ]
 

src/irmin-pack/unix/io.ml

@@ -61,7 +61,9 @@ module Unix = struct
   type create_error = [ `Io_misc of misc_error | `File_exists of string ]
 
   type open_error =
-    [ `Io_misc of misc_error | `No_such_file_or_directory | `Not_a_file ]
+    [ `Io_misc of misc_error
+    | `No_such_file_or_directory of string
+    | `Not_a_file ]
 
   type read_error =
     [ `Io_misc of misc_error
@@ -75,7 +77,7 @@ module Unix = struct
   type mkdir_error =
     [ `Io_misc of misc_error
     | `File_exists of string
-    | `No_such_file_or_directory
+    | `No_such_file_or_directory of string
     | `Invalid_parent_directory ]
 
   let raise_misc_error (x, y, z) = raise (Unix.Unix_error (x, y, z))
@@ -135,7 +137,7 @@ module Unix = struct
   let open_ ~path ~readonly =
     match classify_path path with
     | `Directory | `Other -> Error `Not_a_file
-    | `No_such_file_or_directory -> Error `No_such_file_or_directory
+    | `No_such_file_or_directory -> Error (`No_such_file_or_directory path)
     | `File -> (
         let mode = Unix.(if readonly then O_RDONLY else O_RDWR) in
         try
@@ -282,7 +284,7 @@ module Unix = struct
         with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)))
     | `Directory, (`File | `Directory | `Other) -> Error (`File_exists path)
     | `No_such_file_or_directory, `No_such_file_or_directory ->
-        Error `No_such_file_or_directory
+        Error (`No_such_file_or_directory path)
     | _ -> Error `Invalid_parent_directory
 
   let unlink path =

src/irmin-pack/unix/io_errors.ml

@@ -39,7 +39,7 @@ module Make (Io : Io.S) : S with module Io = Io = struct
     [ `Double_close
     | `File_exists of string
     | `Invalid_parent_directory
-    | `No_such_file_or_directory
+    | `No_such_file_or_directory of string
     | `Not_a_file
     | `Read_out_of_bounds
     | `Invalid_argument

src/irmin-pack/unix/io_intf.ml

@@ -38,7 +38,9 @@ module type S = sig
   type create_error = [ `Io_misc of misc_error | `File_exists of string ]
 
   type open_error =
-    [ `Io_misc of misc_error | `No_such_file_or_directory | `Not_a_file ]
+    [ `Io_misc of misc_error
+    | `No_such_file_or_directory of string
+    | `Not_a_file ]
 
   type read_error =
     [ `Io_misc of misc_error
@@ -52,7 +54,7 @@ module type S = sig
   type mkdir_error =
     [ `Io_misc of misc_error
     | `File_exists of string
-    | `No_such_file_or_directory
+    | `No_such_file_or_directory of string
     | `Invalid_parent_directory ]
 
   (** {1 Safe Functions}
@@ -105,7 +107,9 @@ module type S = sig
   val size_of_path :
     string ->
     ( int63,
-      [> `Io_misc of misc_error | `No_such_file_or_directory | `Not_a_file ] )
+      [> `Io_misc of misc_error
+      | `No_such_file_or_directory of string
+      | `Not_a_file ] )
     result
 
   val classify_path :

src/irmin-pack/unix/mapping_file.ml

@@ -160,7 +160,7 @@ module Make (Io : Io.S) = struct
               (`Corrupted_mapping_file
                 (__FILE__ ^ ": mapping mmap size did not meet size requirements"))
         )
-    | _ -> Error `No_such_file_or_directory
+    | _ -> Error (`No_such_file_or_directory path)
 
   let create ?report_mapping_size ~root ~generation ~register_entries () =
     assert (generation > 0);

src/irmin-pack/unix/mapping_file_intf.ml

@@ -31,7 +31,7 @@ module type S = sig
   module Errs : Io_errors.S with module Io = Io
 
   type open_error :=
-    [ `Corrupted_mapping_file of string | `No_such_file_or_directory ]
+    [ `Corrupted_mapping_file of string | `No_such_file_or_directory of string ]
 
   val create :
     ?report_mapping_size:(int63 -> unit) ->

src/irmin-pack/unix/store.ml

@@ -170,6 +170,21 @@ module Maker (Config : Conf.S) = struct
 
         let v config =
           let root = Irmin_pack.Conf.root config in
+          let _lower_path =
+            (* Validate lower layer root directory.
+
+               TODO: The value is a placeholder which will be used
+               in subsequent chagnes. *)
+            let lower_root = Irmin_pack.Conf.lower_root config in
+            match lower_root with
+            | None -> None
+            | Some path -> (
+                match Io.classify_path path with
+                | `Directory -> Some path
+                | `No_such_file_or_directory ->
+                    Errs.raise_error (`No_such_file_or_directory path)
+                | `File | `Other -> Errs.raise_error (`Not_a_directory path))
+          in
           let fm =
             let readonly = Irmin_pack.Conf.readonly config in
             if readonly then File_manager.open_ro config |> Errs.raise_if_error

test/irmin-pack/common.ml

@@ -179,11 +179,29 @@ module Alcotest = struct
 
   let int63 = testable Int63.pp Int63.equal
 
+  let check_raises_pack_error msg pass f =
+    Lwt.try_bind f
+      (fun _ ->
+        Alcotest.failf
+          "Fail %s: expected function to raise, but it returned instead." msg)
+      (function
+        | Irmin_pack_unix.Errors.Pack_error e as exn -> (
+            match pass e with
+            | true -> Lwt.return_unit
+            | false ->
+                Alcotest.failf
+                  "Fail %s: function raised unexpected exception %s" msg
+                  (Printexc.to_string exn))
+        | exn ->
+            Alcotest.failf
+              "Fail %s: expected function to raise Pack_error, but it raised \
+               %s instead"
+              msg (Printexc.to_string exn))
+
   (** TODO: upstream this to Alcotest *)
   let check_raises_lwt msg exn (type a) (f : unit -> a Lwt.t) =
-    Lwt.catch
-      (fun x ->
-        let* (_ : a) = f x in
+    Lwt.try_bind f
+      (fun _ ->
         Alcotest.failf
           "Fail %s: expected function to raise %s, but it returned instead." msg
           (Printexc.to_string exn))

test/irmin-pack/common.mli

@@ -53,6 +53,13 @@ module Alcotest : sig
   val int63 : Int63.t testable
   val kind : Irmin_pack.Pack_value.Kind.t testable
   val hash : Schema.Hash.t testable
+
+  val check_raises_pack_error :
+    string ->
+    (Irmin_pack_unix.Errors.base_error -> bool) ->
+    (unit -> _ Lwt.t) ->
+    unit Lwt.t
+
   val check_raises_lwt : string -> exn -> (unit -> _ Lwt.t) -> unit Lwt.t
 
   val check_repr :

test/irmin-pack/test_gc.ml

@@ -874,10 +874,9 @@ module Concurrent_gc = struct
     let killed = kill_gc t in
     let* () =
       if killed then
-        Alcotest.check_raises_lwt "Gc process killed"
-          (Irmin_pack_unix.Errors.Pack_error
-             (`Gc_process_died_without_result_file
-               "cancelled \"No_such_file_or_directory\""))
+        Alcotest.check_raises_pack_error "Gc process killed"
+          (function
+            | `Gc_process_died_without_result_file _ -> true | _ -> false)
           (fun () -> finalise_gc t)
       else Lwt.return_unit
     in

test/irmin-pack/test_upgrade.ml

@@ -589,7 +589,10 @@ let open_ro t current_phase =
         let+ repo =
           match (t.setup.start_mode, current_phase) with
           | From_scratch, S1_before_start ->
-              fail_and_skip `No_such_file_or_directory
+              let missing_path =
+                Irmin_pack.Layout.V1_and_v2.pack ~root:root_local_build
+              in
+              fail_and_skip (`No_such_file_or_directory missing_path)
           | From_v2, S1_before_start -> fail_and_skip `Migration_needed
           | (From_v2 | From_v3 | From_v3_c0_gced | From_scratch), _ ->
               Store.v t.setup ~readonly:true ~fresh:false root_local_build