irmin-pack: add context for corrupted control file

src/irmin-pack/unix/control_file.ml

@@ -41,35 +41,37 @@ module Serde = struct
     type raw_payload
 
     val of_bin_string :
+      string ->
       string ->
       ( payload,
-        [> `Corrupted_control_file | `Unknown_major_pack_version of string ] )
+        [> `Corrupted_control_file of string
+        | `Unknown_major_pack_version of string ] )
       result
 
     val raw_of_bin_string :
+      string ->
       string ->
       ( raw_payload,
-        [> `Corrupted_control_file | `Unknown_major_pack_version of string ] )
+        [> `Corrupted_control_file of string
+        | `Unknown_major_pack_version of string ] )
       result
 
     val to_bin_string : payload -> string
   end
 
-  let extract_version_and_payload s =
+  let extract_version_and_payload ctx s =
     let open Result_syntax in
     let len = String.length s in
     let* left, right =
       try Ok (String.sub s 0 8, String.sub s 8 (len - 8))
-      with Invalid_argument _ -> Error `Corrupted_control_file
+      with Invalid_argument _ -> Error (`Corrupted_control_file ctx)
     in
     let+ version =
       match Version.of_bin left with
       | None -> Error (`Unknown_major_pack_version left)
       | Some (`V1 | `V2) -> assert false (* TODO: create specific error *)
       | Some ((`V3 | `V4 | `V5) as x) ->
-          if len > Io.Unix.page_size then
-            (* TODO: make this a more specific error *)
-            Error `Corrupted_control_file
+          if len > Io.Unix.page_size then Error (`Corrupted_control_file ctx)
           else Ok x
     in
     (version, right)
@@ -131,9 +133,9 @@ module Serde = struct
             let payload = Plv5.set_checksum payload in
             Version.to_bin `V5 ^ Plv5.to_bin_string payload
 
-      let of_bin_string s =
+      let of_bin_string ctx s =
         let open Result_syntax in
-        let* version, payload = extract_version_and_payload s in
+        let* version, payload = extract_version_and_payload ctx s in
         let route_version () =
           match version with
           | `V3 ->
@@ -154,7 +156,7 @@ module Serde = struct
         in
         match route_version () with
         | Ok _ as x -> x
-        | Error _ -> Error `Corrupted_control_file
+        | Error _ -> Error (`Corrupted_control_file ctx)
     end
 
     module Latest = Data.Plv5
@@ -210,11 +212,11 @@ module Serde = struct
         volume_num = 0;
       }
 
-    let of_bin_string string =
+    let of_bin_string ctx string =
       let open Result_syntax in
-      let* payload = Data.of_bin_string string in
+      let* payload = Data.of_bin_string ctx string in
       match payload with
-      | Invalid _ -> Error `Corrupted_control_file
+      | Invalid _ -> Error (`Corrupted_control_file ctx)
       | Valid (V3 payload) -> Ok (upgrade_from_v3 payload)
       | Valid (V4 payload) -> Ok (upgrade_from_v4 payload)
       | Valid (V5 payload) -> Ok payload
@@ -260,9 +262,9 @@ module Serde = struct
             let payload = Plv5.set_checksum payload in
             Version.to_bin `V5 ^ Plv5.to_bin_string payload
 
-      let of_bin_string s =
+      let of_bin_string ctx s =
         let open Result_syntax in
-        let* version, payload = extract_version_and_payload s in
+        let* version, payload = extract_version_and_payload ctx s in
         let route_version () =
           match version with
           | `V3 | `V4 -> assert false
@@ -275,19 +277,19 @@ module Serde = struct
         in
         match route_version () with
         | Ok _ as x -> x
-        | Error _ -> Error `Corrupted_control_file
+        | Error _ -> Error (`Corrupted_control_file ctx)
     end
 
     module Payload = Data.Plv5
 
     type payload = Payload.t
     type raw_payload = Data.t
 
-    let of_bin_string string =
+    let of_bin_string ctx string =
       let open Result_syntax in
-      let* payload = Data.of_bin_string string in
+      let* payload = Data.of_bin_string ctx string in
       match payload with
-      | Invalid _ -> Error `Corrupted_control_file
+      | Invalid _ -> Error (`Corrupted_control_file ctx)
       | Valid (V5 payload) -> Ok payload
 
     let raw_of_bin_string = Data.of_bin_string
@@ -328,7 +330,7 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct
   let read io =
     let open Result_syntax in
     let* string = Io.read_all_to_string io in
-    Serde.of_bin_string string
+    Serde.of_bin_string (Io.path io) string
 
   let create_rw ~path ~tmp_path ~overwrite (payload : payload) =
     let open Result_syntax in
@@ -367,7 +369,7 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct
     let open Result_syntax in
     let* io = Io.open_ ~path ~readonly:true in
     let* string = Io.read_all_to_string io in
-    let* payload = Serde.raw_of_bin_string string in
+    let* payload = Serde.raw_of_bin_string path string in
     let+ () = Io.close io in
     payload
 

src/irmin-pack/unix/control_file_intf.ml

@@ -309,7 +309,7 @@ module type S = sig
   (** Create a rw instance of [t] by creating a control file. *)
 
   type open_error :=
-    [ `Corrupted_control_file
+    [ `Corrupted_control_file of string
     | `Io_misc of Io.misc_error
     | `No_such_file_or_directory of string
     | `Not_a_file
@@ -350,14 +350,7 @@ module type S = sig
       [payload t] is the [payload], as it was seen during [open_] or during the
       most recent [reload]. *)
 
-  type reload_error :=
-    [ `Corrupted_control_file
-    | `Io_misc of Io.misc_error
-    | `Closed
-    | `Rw_not_allowed
-    | `Unknown_major_pack_version of string
-    | open_error
-    | Io.close_error ]
+  type reload_error := [ `Rw_not_allowed | open_error | Io.close_error ]
 
   val reload : t -> (unit, [> reload_error ]) result
   (** {3 RW mode}

src/irmin-pack/unix/errors.ml

@@ -52,7 +52,7 @@ type base_error =
   | `Rw_not_allowed
   | `Migration_needed
   | `Migration_to_lower_not_allowed
-  | `Corrupted_control_file
+  | `Corrupted_control_file of string
   | `Sys_error of string
   | `V3_store_from_the_future
   | `Gc_forbidden_during_batch

src/irmin-pack/unix/file_manager.ml

@@ -809,7 +809,7 @@ struct
         | Error `Not_a_file -> Error `Invalid_layout
         | Error `Closed -> assert false
         | Error
-            ( `Io_misc _ | `Corrupted_control_file
+            ( `Io_misc _ | `Corrupted_control_file _
             | `Unknown_major_pack_version _ ) as e ->
             e)
 

src/irmin-pack/unix/file_manager_intf.ml

@@ -84,7 +84,7 @@ module type S = sig
     | Io.open_error
     | Io.mkdir_error
     | `Corrupted_mapping_file of string
-    | `Corrupted_control_file
+    | `Corrupted_control_file of string
     | `Double_close
     | `Unknown_major_pack_version of string
     | `Volume_missing of string
@@ -108,7 +108,7 @@ module type S = sig
       undefined state and some file descriptors might not be closed. *)
 
   type open_rw_error :=
-    [ `Corrupted_control_file
+    [ `Corrupted_control_file of string
     | `Corrupted_mapping_file of string
     | `Double_close
     | `Closed
@@ -158,7 +158,7 @@ module type S = sig
       is unaffected. Anyhow, some file descriptors might not be closed. *)
 
   type open_ro_error :=
-    [ `Corrupted_control_file
+    [ `Corrupted_control_file of string
     | `Corrupted_mapping_file of string
     | `Io_misc of Io.misc_error
     | `Migration_needed
@@ -246,7 +246,7 @@ module type S = sig
   val register_suffix_consumer : t -> after_flush:(unit -> unit) -> unit
 
   type version_error :=
-    [ `Corrupted_control_file
+    [ `Corrupted_control_file of string
     | `Corrupted_legacy_file
     | `Invalid_layout
     | `Io_misc of Io.misc_error

src/irmin-pack/unix/io_errors.ml

@@ -53,7 +53,7 @@ module Make (Io : Io.S) : S with module Io = Io = struct
     | `Rw_not_allowed
     | `Migration_needed
     | `Migration_to_lower_not_allowed
-    | `Corrupted_control_file
+    | `Corrupted_control_file of string
     | `Sys_error of string
     | `V3_store_from_the_future
     | `Gc_forbidden_during_batch

src/irmin-pack/unix/lower.ml

@@ -37,7 +37,7 @@ module Make_volume (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct
     [ Io.open_error
     | `Closed
     | `Double_close
-    | `Corrupted_control_file
+    | `Corrupted_control_file of string
     | `Unknown_major_pack_version of string ]
 
   let v volume_path =

src/irmin-pack/unix/lower_intf.ml

@@ -29,7 +29,7 @@ module type Volume = sig
     [ Io.open_error
     | `Closed
     | `Double_close
-    | `Corrupted_control_file
+    | `Corrupted_control_file of string
     | `Unknown_major_pack_version of string ]
 
   val v : string -> (t, [> open_error ]) result

test/irmin-pack/test_corrupted.ml

@@ -75,9 +75,11 @@ let test_corrupted_control_file () =
         Ok r)
       (fun exn -> Lwt.return (Error exn))
   in
-  Alcotest.(check bool)
-    "is corrupted" true
-    (error = Error (Irmin_pack_unix.Errors.Pack_error `Corrupted_control_file));
+  (match error with
+  | Error (Irmin_pack_unix.Errors.Pack_error (`Corrupted_control_file s)) ->
+      Alcotest.(check string)
+        "path is corrupted" s "_build/test-corrupted/store.control"
+  | _ -> Alcotest.fail "unexpected error");
   Lwt.return_unit
 
 let tests =