Repository: mirage/ocaml-tar
Pull request #108 (2023-02-02 15:51:57)

Implement remove
This implements `remove` with a big constraint: only the last file can be removed. Otherwise, ``Error `Append_only`` is returned. The reason is removing the last file only requires overwriting the header and the following block with zeroes whereas removing files at other positions require moving potentially large amounts of data.

I believe I also found an off-by-one error when computing end sectors which this fixes as well.


Patch:
diff --git a/mirage/tar_mirage.ml b/mirage/tar_mirage.ml
index 0ffa9a5..278c07b 100644
--- a/mirage/tar_mirage.ml
+++ b/mirage/tar_mirage.ml
@@ -130,13 +130,13 @@ module Make_KV_RO (BLOCK : Mirage_block.S) = struct
     match get_node t.map key with
     | Error e -> Lwt.return (Error e)
     | Ok (Dict _) -> Lwt.return (Error (`Value_expected key))
-    | Ok (Value (hdr, start_sector)) ->
+    | Ok (Value (hdr, start_block)) ->
       let open Int64 in
       let offset = Optint.Int63.to_int64 offset in
       let sector_size = of_int t.info.Mirage_block.sector_size in
       (* Compute the unaligned data we need to read *)
       let start_bytes =
-        let sec = mul start_sector 512L in
+        let sec = mul start_block 512L in
         add sec offset
       in
       let length_bytes =
@@ -430,7 +430,7 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
           div data_start_bytes sector_size,
           rem data_start_bytes sector_size
         in
-        let end_sector = div (add end_bytes sector_size) sector_size in
+        let end_sector = div (add end_bytes (pred sector_size)) sector_size in
         let last_sector_offset = rem end_bytes sector_size in
         let pad = Tar.Header.compute_zero_padding_length hdr in
 
@@ -487,8 +487,48 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
         t.map <- update_insert t.map key hdr tar_offset;
         Lwt.return (Ok ()))
 
-  let remove _ _ =
-    Lwt.return (Error `Append_only)
+  let remove t key =
+    let ( >>>= ) = Lwt_result.bind in
+    Lwt_mutex.with_lock t.write_lock (fun () ->
+        match get_node t.map key with
+        | Error e -> Lwt.return (Error e)
+        | Ok (Dict _) -> Lwt.return (Error (`Value_expected key))
+        | Ok (Value (hdr, start_block)) ->
+          let end_bytes = Int64.(add hdr.file_size (mul start_block 512L)) in
+          (* We can only easily remove if the key is the very last entry. *)
+          let open Int64 in
+          if equal end_bytes (sub t.end_of_archive 1024L) then begin
+            t.map <- update_remove t.map key;
+            let start_bytes = mul (pred start_block) 512L in
+            let sector_size = of_int t.info.sector_size in
+            let start_sector, start_sector_offset =
+              div start_bytes sector_size, rem start_bytes sector_size
+            in
+            let end_sector, last_sector_offset =
+              let end_bytes = add start_bytes 1024L in
+              div (add end_bytes (pred sector_size)) sector_size, rem start_bytes sector_size
+            in
+            let buf = Cstruct.create (to_int (mul sector_size (sub end_sector start_sector))) in
+            let first_sector = Cstruct.sub buf 0 t.info.sector_size in
+            let last_sector =
+              Cstruct.sub buf (Cstruct.length buf - t.info.sector_size) t.info.sector_size
+            in
+            read_partial_sector t start_sector_offset first_sector
+              ~offset:0L ~length:start_sector_offset >>>= fun () ->
+            begin if last_sector_offset = 0L then Lwt_result.return () else
+                read_partial_sector t (pred end_sector) last_sector
+                  ~offset:last_sector_offset ~length:(sub sector_size last_sector_offset)
+            end >>>= fun () ->
+            (* To remove as robustly as possible we first zero the second
+               sector (if applicable). *)
+            if Cstruct.length buf > t.info.sector_size then
+              write t start_sector
+                [Cstruct.sub buf t.info.sector_size t.info.sector_size] >>>= fun () ->
+              write t start_sector [Cstruct.sub buf 0 t.info.sector_size]
+            else
+              write t start_sector [buf]
+          end else
+            Lwt.return (Error `Append_only))
 
   let rename t ~source ~dest =
     let ( >>>= ) = Lwt_result.bind in
@@ -529,7 +569,7 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
         let start_bytes = add data_offset offset in
         let sector_size = of_int t.info.sector_size in
         let start_sector_offset = rem start_bytes sector_size in
-        let end_sector = div (add end_bytes sector_size) sector_size in
+        let end_sector = div (add end_bytes (pred sector_size)) sector_size in
         let last_sector_offset = rem end_bytes sector_size in
         (* allocate a buffer for what we need to write, and blit in data and slack
            at first and last sector. *)
@@ -600,7 +640,7 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
           rem to_zero_start_bytes sector_size
         in
         let last_sector_offset = rem end_bytes sector_size in
-        let end_sector = div (add end_bytes sector_size) sector_size in
+        let end_sector = div (add end_bytes (pred sector_size)) sector_size in
         (* [num_to_zero_sectors] is at least 1 as we need to write at least one
            zero block of the new sentinel. *)
         let num_to_zero_sectors = to_int (sub end_sector to_zero_start_sector) in


Test patch:
diff --git a/lib_test/write_test.ml b/lib_test/write_test.ml
index a8ba060..1ff4221 100644
--- a/lib_test/write_test.ml
+++ b/lib_test/write_test.ml
@@ -88,6 +88,32 @@ module Test(B : BLOCK) = struct
     KV_RW.set t (Mirage_kv.Key.v "second") (str (2 * B.block_size - 512)) >>=
     kv_rw_write_error >>= fun () ->
     Lwt.return_unit
+
+  let write_two_files_remove_first ctx =
+    let first = Mirage_kv.Key.v "first" and second = Mirage_kv.Key.v "second" in
+    connect_block ctx >>= fun b ->
+    resize b 10240L >>= fun () ->
+    KV_RW.connect b >>= fun t ->
+    KV_RW.set t first (str (B.block_size - 512)) >>=
+    kv_rw_write_error >>= fun () ->
+    KV_RW.set t second (str (2 * B.block_size - 512)) >>=
+    kv_rw_write_error >>= fun () ->
+    KV_RW.remove t first >>= function
+    | Error _ (* XXX: `Append_only *) ->
+      Lwt.return_unit
+    | Ok () -> OUnit2.assert_failure "Expected Error `Append_only"
+
+  let write_two_files_remove_second ctx =
+    let first = Mirage_kv.Key.v "first" and second = Mirage_kv.Key.v "second" in
+    connect_block ctx >>= fun b ->
+    resize b 10240L >>= fun () ->
+    KV_RW.connect b >>= fun t ->
+    KV_RW.set t first (str (B.block_size - 512)) >>=
+    kv_rw_write_error >>= fun () ->
+    KV_RW.set t second (str (2 * B.block_size - 512)) >>=
+    kv_rw_write_error >>= fun () ->
+    KV_RW.remove t second >>=
+    kv_rw_write_error
 end
 
 module Test512 = Test(Block512)
@@ -107,6 +133,10 @@ let () =
       "write two blocks 4096" >:: OUnitLwt.lwt_wrapper Test4096.write_two_block_size;
       "write two files 512" >:: OUnitLwt.lwt_wrapper Test512.write_two_files;
       "write two files 4096" >:: OUnitLwt.lwt_wrapper Test4096.write_two_files;
+      "write two files remove first 512" >:: OUnitLwt.lwt_wrapper Test512.write_two_files_remove_first;
+      "write two files remove first 4096" >:: OUnitLwt.lwt_wrapper Test4096.write_two_files_remove_first;
+      "write two files remove second 512" >:: OUnitLwt.lwt_wrapper Test512.write_two_files_remove_second;
+      "write two files remove second 4096" >:: OUnitLwt.lwt_wrapper Test4096.write_two_files_remove_second;
     ]
   in
   run_test_tt_main suite