Merge pull request #6 from djs55/add-skeleton

Add `fold_s`

README.md

@@ -2,3 +2,5 @@ Block implementations for mirage
 ================================
 
 This repo contains generic operations over Mirage `BLOCK` devices.
+
+Please consult [the API documentation](https://mirage.github.io/mirage-block/index.html).

_oasis

@@ -8,11 +8,11 @@ Plugins:     META (0.3)
 BuildTools:  ocamlbuild
 
 Library mirage_block
-  Pack:               true
+  Pack:               false
   CompiledObject:     best
   Path:               lib
   Findlibname:        mirage-block
-  Modules:            Copy, Ramdisk, Patterns, Compare
+  Modules:            Mirage_block, Mirage_block_copy, Ramdisk, Mirage_block_patterns, Mirage_block_compare, Mirage_block_iter
   BuildDepends:       cstruct, io-page, mirage-types.lwt, lwt
 
 Document mirage_block

lib/mirage_block.ml

@@ -0,0 +1,25 @@
+(*
+ * Copyright (C) 2015 David Scott <dave.scott@unikernel.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+let fold_s = Mirage_block_iter.fold_s
+
+let compare = Mirage_block_compare.compare
+
+let copy = Mirage_block_copy.copy
+
+let random = Mirage_block_patterns.random
+

lib/mirage_block.mli

@@ -0,0 +1,47 @@
+(*
+ * Copyright (C) 2015 David Scott <dave.scott@unikernel.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+(** Utility functions over Mirage [BLOCK] devices *)
+
+val compare:
+  (module V1_LWT.BLOCK with type t = 'a) -> 'a ->
+  (module V1_LWT.BLOCK with type t = 'b) -> 'b ->
+  [ `Ok of int | `Error of [> `Msg of string ]] Lwt.t
+(** Compare the contents of two block devices. *)
+
+val fold_s:
+  f:('a -> int64 -> Cstruct.t -> 'a Lwt.t) -> 'a ->
+  (module V1_LWT.BLOCK with type t = 'b) -> 'b ->
+  [ `Ok of 'a | `Error of [> `Msg of string ]] Lwt.t
+(** Folds [f] across blocks read sequentially from a block device *)
+
+val copy:
+  (module V1_LWT.BLOCK with type t = 'a) -> 'a ->
+  (module V1_LWT.BLOCK with type t = 'b) -> 'b ->
+  [ `Ok of unit | `Error of [> `Msg of string | `Is_read_only | `Different_sizes ]] Lwt.t
+(** Copy all data from a source BLOCK device to a destination BLOCK device.
+
+    Fails with `Different_sizes if the source and destination are not exactly
+    the same size.
+
+    Fails with `Is_read_only if the destination device is read-only.
+*)
+
+val random:
+  (module V1_LWT.BLOCK with type t = 'a) -> 'a ->
+  [ `Ok of unit | `Error of [> `Msg of string ]] Lwt.t
+(** Fill a block device with pseudorandom data *)

lib/mirage_block_iter.ml

@@ -0,0 +1,48 @@
+(*
+ * Copyright (C) 2015 David Scott <dave.scott@unikernel.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+open Lwt
+
+let error_to_string = function
+  | `Unknown x -> x
+  | `Unimplemented -> "Unimplemented"
+  | `Is_read_only -> "Is_read_only"
+  | `Disconnected -> "Disconnected"
+
+let fold_s ~f init
+  (type block) (module Block: V1_LWT.BLOCK with type t = block) (b: block) =
+  Block.get_info b
+  >>= fun info ->
+  let buffer = Io_page.(to_cstruct (get 8)) in
+  let sectors = Cstruct.len buffer / info.Block.sector_size in
+
+  let rec loop acc next =
+    if next >= info.Block.size_sectors
+    then return (`Ok acc)
+    else begin
+      let remaining = Int64.sub info.Block.size_sectors next in
+      let this_time = min sectors (Int64.to_int remaining) in
+      let buf = Cstruct.sub buffer 0 (info.Block.sector_size * this_time) in
+      Block.read b next [ buf ]
+      >>= function
+      | `Error e ->
+        return (`Error (`Msg (error_to_string e)))
+      | `Ok () ->
+        f acc Int64.(mul next (of_int info.Block.sector_size)) buf
+        >>= fun acc ->
+        loop acc Int64.(add next (of_int this_time))
+    end in
+  loop init 0L

lib/mirage_block_iter.mli

@@ -0,0 +1,22 @@
+(*
+ * Copyright (C) 2015 David Scott <dave.scott@unikernel.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+val fold_s:
+  f:('a -> int64 -> Cstruct.t -> 'a Lwt.t) -> 'a ->
+  (module V1_LWT.BLOCK with type t = 'b) -> 'b ->
+  [ `Ok of 'a | `Error of [> `Msg of string ]] Lwt.t
+(** Folds [f] across blocks read sequentially from a block device *)

lib_test/tests.ml

@@ -14,7 +14,6 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *
  *)
-open Mirage_block
 open Lwt
 open OUnit
 
@@ -35,7 +34,7 @@ let ramdisk_compare () =
     Ramdisk.connect ~name:"dest"
     >>= fun x ->
     let dest = expect_ok "dest" x in
-    Compare.compare (module Ramdisk) from (module Ramdisk) dest
+    Mirage_block.compare (module Ramdisk) from (module Ramdisk) dest
     >>= fun x ->
     let x = expect_ok_msg x in
     assert_equal ~printer:string_of_int 0 x; return () in
@@ -46,13 +45,13 @@ let different_compare () =
     Ramdisk.connect ~name:"from"
     >>= fun x ->
     let from = expect_ok "from" x in
-    Patterns.random (module Ramdisk) from
+    Mirage_block.random (module Ramdisk) from
     >>= fun x ->
     let () = expect_ok "patterns" x in
     Ramdisk.connect ~name:"dest"
     >>= fun x ->
     let dest = expect_ok "dest" x in
-    Compare.compare (module Ramdisk) from (module Ramdisk) dest
+    Mirage_block.compare (module Ramdisk) from (module Ramdisk) dest
     >>= fun x ->
     let x = expect_ok_msg x in
     if x = 0 then failwith "different disks compared the same";
@@ -67,10 +66,10 @@ let basic_copy () =
     Ramdisk.connect ~name:"dest"
     >>= fun x ->
     let dest = expect_ok "dest" x in
-    Copy.copy (module Ramdisk) from (module Ramdisk) dest
+    Mirage_block.copy (module Ramdisk) from (module Ramdisk) dest
     >>= fun x ->
     let () = expect_ok_msg x in
-    Compare.compare (module Ramdisk) from (module Ramdisk) dest
+    Mirage_block.compare (module Ramdisk) from (module Ramdisk) dest
     >>= fun x ->
     let x = expect_ok_msg x in
     assert_equal ~printer:string_of_int 0 x; return () in
@@ -81,16 +80,16 @@ let random_copy () =
     Ramdisk.connect ~name:"from"
     >>= fun x ->
     let from = expect_ok "from" x in
-    Patterns.random (module Ramdisk) from
+    Mirage_block.random (module Ramdisk) from
     >>= fun x ->
     let () = expect_ok "patterns" x in
     Ramdisk.connect ~name:"dest"
     >>= fun x ->
     let dest = expect_ok "dest" x in
-    Copy.copy (module Ramdisk) from (module Ramdisk) dest
+    Mirage_block.copy (module Ramdisk) from (module Ramdisk) dest
     >>= fun x ->
     let () = expect_ok_msg x in
-    Compare.compare (module Ramdisk) from (module Ramdisk) dest
+    Mirage_block.compare (module Ramdisk) from (module Ramdisk) dest
     >>= fun x ->
     let x = expect_ok_msg x in
     assert_equal ~printer:string_of_int 0 x; return () in