Merge pull request #13 from djs55/fix-fold-unmapped

`fold_unmapped_s`: don't return buffers of zeroes

lib/mirage_block.mli

@@ -43,13 +43,13 @@ val fold_mapped_s:
     buffer. *)
 
 val fold_unmapped_s:
-  f:('a -> int64 -> Cstruct.t -> 'a Mirage_block_error.result Lwt.t) -> 'a ->
+  f:('a -> int64 -> int64 -> 'a Mirage_block_error.result Lwt.t) -> 'a ->
   (module Mirage_block_s.SEEKABLE with type t = 'b) -> 'b ->
   'a Mirage_block_error.result Lwt.t
-(** Folds [f] across data blocks read sequentially from a block device.
-    In contrast to [fold_s], [fold_unmapped_s] will use knowledge about the
-    underlying disk structure and will only fold across those blocks which
-    are guaranteed to be zero i.e. those which are unmapped somehow. *)
+(** Folds [f acc ofs len] across offsets of unmapped data blocks read
+    sequentially from the block device. [fold_unmapped_s] will use knowledge
+    about the underlying disk structure and will only fold across those blocks
+    which are guaranteed to be zero i.e. those which are unmapped somehow. *)
 
 val copy:
   (module V1_LWT.BLOCK with type t = 'a) -> 'a ->

lib/mirage_block_iter.ml

@@ -89,15 +89,23 @@ let fold_mapped_s ~f init
   >>= fun start ->
   loop init start
 
-(* If we flip the functions [seek_mapped] and [seek_unmapped] then
-   we can use [fold_mapped_s] to fold over the unmapped data instead *)
-
-module Flip(Input: Mirage_block_s.SEEKABLE) = struct
-  include Input
-  let seek_mapped, seek_unmapped = seek_unmapped, seek_mapped
-end
-
 let fold_unmapped_s ~f init
   (type seekable) (module Seekable: Mirage_block_s.SEEKABLE with type t = seekable) (s: seekable) =
-  let module Flipped = Flip(Seekable) in
-  fold_mapped_s ~f init (module Flipped) s
+  Seekable.get_info s
+  >>= fun info ->
+
+  let open Mirage_block_error.Monad.Infix in
+  let rec loop acc next =
+    (* next points to the next mapped chunk (or end of device) *)
+    if next >= info.Seekable.size_sectors
+    then return (`Ok acc)
+    else begin
+      Seekable.seek_unmapped s next
+      >>= fun next_unmapped ->
+      Seekable.seek_mapped s next_unmapped
+      >>= fun next_mapped ->
+      f acc next_unmapped (Int64.sub next_mapped next_unmapped)
+      >>= fun acc ->
+      loop acc next_mapped
+    end in
+  loop init 0L