irmin-pack: Use temp control files upon writing

src/irmin-pack/layout.ml

@@ -54,6 +54,7 @@ module V4 = struct
   let branch = toplevel "store.branches"
   let dict = toplevel "store.dict"
   let control = toplevel "store.control"
+  let temp_control = toplevel "store.control.tmp"
 
   let suffix_chunk ~chunk_idx =
     toplevel ("store." ^ string_of_int chunk_idx ^ ".suffix")
@@ -80,6 +81,7 @@ module V5 = struct
   module Volume = struct
     let directory ~idx = toplevel ("volume." ^ string_of_int idx)
     let control = toplevel "volume.control"
+    let temp_control = toplevel "volume.control.tmp"
     let mapping = toplevel "volume.mapping"
     let data = toplevel "volume.data"
   end
@@ -110,6 +112,7 @@ module Classification = struct
       | `Reachable of int
       | `Sorted of int
       | `Suffix of int
+      | `Temp_control
       | `V1_or_v2_pack
       | `Unknown ]
     [@@deriving irmin]
@@ -119,6 +122,7 @@ module Classification = struct
       | [ "store"; "pack" ] -> `V1_or_v2_pack
       | [ "store"; "branches" ] -> `Branch
       | [ "store"; "control" ] -> `Control
+      | [ "store"; "control"; "tmp" ] -> `Temp_control
       | [ "store"; "dict" ] -> `Dict
       | [ "store"; g; "out" ] when is_number g -> `Gc_result (int_of_string g)
       | [ "store"; g; "reachable" ] when is_number g ->
@@ -131,11 +135,12 @@ module Classification = struct
   end
 
   module Volume = struct
-    type t = [ `Mapping | `Data | `Control | `Unknown ] [@@deriving irmin]
+    type t = [ `Mapping | `Data | `Control | `Temp_control | `Unknown ] [@@deriving irmin]
 
     let v s : t =
       match String.split_on_char '.' s with
       | [ "volume"; "control" ] -> `Control
+      | [ "volume"; "control"; "tmp" ] -> `Temp_control
       | [ "volume"; "mapping" ] -> `Mapping
       | [ "volume"; "data" ] -> `Data
       | _ -> `Unknown

src/irmin-pack/unix/control_file.ml

@@ -299,7 +299,7 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct
   module Io = Io
 
   type payload = Serde.payload
-  type t = { mutable io : Io.t; mutable payload : payload; path : string }
+  type t = { mutable io : Io.t; mutable payload : payload; path : string; tmp_path : string }
 
   let write io payload =
     let s = Serde.to_bin_string payload in
@@ -308,29 +308,28 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct
   let set_payload t payload =
     let open Result_syntax in
     let* () = Io.close t.io in
-    let path_tmp = t.path ^ ".tmp" in
-    let* io_tmp = Io.create ~path:path_tmp ~overwrite:true in
+    let* io_tmp = Io.create ~path:t.tmp_path ~overwrite:true in
     t.io <- io_tmp;
     let* () = write io_tmp payload in
-    let+ () = Io.move_file ~src:path_tmp ~dst:t.path in
+    let+ () = Io.move_file ~src:t.tmp_path ~dst:t.path in
     t.payload <- payload
 
   let read io =
     let open Result_syntax in
     let* string = Io.read_all_to_string io in
     Serde.of_bin_string string
 
-  let create_rw ~path ~overwrite (payload : payload) =
+  let create_rw ~path ~tmp_path ~overwrite (payload : payload) =
     let open Result_syntax in
     let* io = Io.create ~path ~overwrite in
     let+ () = write io payload in
-    { io; payload; path }
+    { io; payload; path; tmp_path }
 
-  let open_ ~path ~readonly =
+  let open_ ~path ~tmp_path ~readonly =
     let open Result_syntax in
     let* io = Io.open_ ~path ~readonly in
     let+ payload = read io in
-    { io; payload; path }
+    { io; payload; path; tmp_path }
 
   let close t = Io.close t.io
   let readonly t = Io.readonly t.io
@@ -348,9 +347,9 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct
 
   let read_payload ~path =
     let open Result_syntax in
-    let* t = open_ ~path ~readonly:true in
-    let payload = payload t in
-    let+ () = close t in
+    let* io = Io.open_ ~path ~readonly:true in
+    let* payload = read io in
+    let+ () = Io.close io in
     payload
 
   let read_raw_payload ~path =

src/irmin-pack/unix/control_file_intf.ml

@@ -305,6 +305,7 @@ module type S = sig
 
   val create_rw :
     path:string ->
+    tmp_path:string ->
     overwrite:bool ->
     payload ->
     (t, [> Io.create_error | Io.write_error ]) result
@@ -318,7 +319,7 @@ module type S = sig
     | `Closed
     | `Unknown_major_pack_version of string ]
 
-  val open_ : path:string -> readonly:bool -> (t, [> open_error ]) result
+  val open_ : path:string -> tmp_path:string -> readonly:bool -> (t, [> open_error ]) result
   (** Create a rw instance of [t] by reading an existing file at [path]. *)
 
   val close : t -> (unit, [> Io.close_error ]) result

src/irmin-pack/unix/file_manager.ml

@@ -265,7 +265,7 @@ struct
           | `Prefix g | `Mapping g -> g <> generation
           | `Suffix idx ->
               idx < chunk_start_idx || idx > chunk_start_idx + chunk_num
-          | `Reachable _ | `Sorted _ | `Gc_result _ -> true)
+          | `Reachable _ | `Sorted _ | `Gc_result _ | `Temp_control -> true)
         files
     in
     List.iter
@@ -382,7 +382,8 @@ struct
   let create_control_file ~overwrite config pl =
     let root = Irmin_pack.Conf.root config in
     let path = Layout.control ~root in
-    Control.create_rw ~path ~overwrite pl
+    let tmp_path = Layout.temp_control ~root in
+    Control.create_rw ~path ~tmp_path ~overwrite pl
 
   (* Reload ***************************************************************** *)
 
@@ -491,7 +492,8 @@ struct
     let lower_root = Irmin_pack.Conf.lower_root config in
     let* control =
       let path = Layout.control ~root in
-      Control.open_ ~readonly:false ~path
+      let tmp_path = Layout.temp_control ~root in
+      Control.open_ ~readonly:false ~path ~tmp_path
     in
     let Payload.
           {
@@ -629,7 +631,8 @@ struct
     (* 1. Open the control file *)
     let* control =
       let path = Layout.control ~root in
-      Control.open_ ~readonly:true ~path
+      let tmp_path = Layout.temp_control ~root in
+      Control.open_ ~readonly:true ~path ~tmp_path
       (* If no control file, then check whether the store is in v1 or v2. *)
       |> Result.map_error (function
            | `No_such_file_or_directory _ -> (
@@ -720,7 +723,8 @@ struct
     | `File | `Other -> Error (`Not_a_directory root)
     | `Directory -> (
         let path = Layout.control ~root in
-        match Control.open_ ~path ~readonly:true with
+        let tmp_path = Layout.temp_control ~root in
+        match Control.open_ ~path ~tmp_path ~readonly:true with
         | Ok _ -> Ok `V3
         | Error (`No_such_file_or_directory _) -> v2_or_v1 ()
         | Error `Not_a_file -> Error `Invalid_layout
@@ -893,7 +897,8 @@ struct
       }
     in
     let path = Layout.control ~root:dst_root in
-    let* control = Control.create_rw ~path ~overwrite:false pl in
+    let tmp_path = Layout.temp_control ~root:dst_root in
+    let* control = Control.create_rw ~path ~tmp_path ~overwrite:false pl in
     let* () = Control.close control in
     (* Step 4. Create the index. *)
     let* index =

test/irmin-pack/test_lower.ml

@@ -32,7 +32,8 @@ module Direct_tc = struct
 
   let create_control volume_path payload =
     let path = Irmin_pack.Layout.V5.Volume.control ~root:volume_path in
-    Control.create_rw ~path ~overwrite:true payload
+    let tmp_path = Irmin_pack.Layout.V5.Volume.temp_control ~root:volume_path in
+    Control.create_rw ~path ~tmp_path ~overwrite:true payload
 
   let test_empty () =
     let lower_root = create_lower_root () in

test/irmin-pack/test_pack.ml

@@ -505,6 +505,7 @@ module Layout = struct
     c `V1_or_v2_pack (V1_and_v2.pack ~root:"" |> classif);
     c `Branch (V4.branch ~root:"" |> classif);
     c `Control (V4.control ~root:"" |> classif);
+    c `Temp_control (V4.temp_control ~root:"" |> classif);
     c `Dict (V4.dict ~root:"" |> classif);
     c (`Gc_result 0) (V4.gc_result ~generation:0 ~root:"" |> classif);
     c (`Reachable 1) (V4.reachable ~generation:1 ~root:"" |> classif);
@@ -528,6 +529,7 @@ module Layout = struct
     let c = Alcotest.(check (testable_repr Classification.t)) "" in
     let classif = Classification.v in
     c `Control (V5.control ~root:"" |> classif);
+    c `Temp_control (V5.temp_control ~root:"" |> classif);
     c `Mapping (V5.mapping ~root:"" |> classif);
     c `Data (V5.data ~root:"" |> classif);
     c `Unknown (classif "store.toto");