Merge pull request #5 from djs55/add-skeleton

Add a block device copy

_oasis

@@ -12,7 +12,7 @@ Library mirage_block
   CompiledObject:     best
   Path:               lib
   Findlibname:        mirage-block
-  Modules:            Copy
+  Modules:            Copy, Ramdisk, Patterns, Compare
   BuildDepends:       cstruct, io-page, mirage-types.lwt, lwt
 
 Document mirage_block
@@ -30,7 +30,7 @@ Executable test
   Custom:             true
   CompiledObject:     best
   Install:            false
-  BuildDepends:       mirage-block, oUnit (>= 1.0.2)
+  BuildDepends:       mirage-block, oUnit (>= 1.0.2), lwt.unix, io-page.unix
 
 Test test
   Run$:               flag(tests)

lib/compare.ml

@@ -0,0 +1,69 @@
+(*
+ * 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 compare
+  (type from) (module From: V1_LWT.BLOCK with type t = from) (from: from)
+  (type dest) (module Dest: V1_LWT.BLOCK with type t = dest) (dest: dest) =
+
+  From.get_info from
+  >>= fun from_info ->
+  Dest.get_info dest
+  >>= fun dest_info ->
+
+  let total_size_from = Int64.(mul from_info.From.size_sectors (of_int from_info.From.sector_size)) in
+  let total_size_dest = Int64.(mul dest_info.Dest.size_sectors (of_int dest_info.Dest.sector_size)) in
+  match compare
+    (from_info.From.size_sectors, total_size_from)
+    (dest_info.Dest.size_sectors, total_size_dest) with
+  | ((-1) | 1) as x -> return (`Ok x)
+  | _ ->
+
+    let from_buffer = Io_page.(to_cstruct (get 8)) in
+    let dest_buffer = Io_page.(to_cstruct (get 8)) in
+    let sectors = Cstruct.len from_buffer / from_info.From.sector_size in
+
+    let rec loop next =
+      if next >= from_info.From.size_sectors
+      then return (`Ok 0)
+      else begin
+        let remaining = Int64.sub from_info.From.size_sectors next in
+        let this_time = min sectors (Int64.to_int remaining) in
+        let from_buf = Cstruct.sub from_buffer 0 (from_info.From.sector_size * this_time) in
+        let dest_buf = Cstruct.sub dest_buffer 0 (dest_info.Dest.sector_size * this_time) in
+        From.read from next [ from_buf ]
+        >>= function
+        | `Error e ->
+          return (`Error (`Msg (error_to_string e)))
+        | `Ok () ->
+          Dest.read dest next [ dest_buf ]
+          >>= function
+          | `Error e ->
+            return (`Error (`Msg (error_to_string e)))
+          | `Ok () ->
+            match Cstruct.compare from_buf dest_buf with
+            | 0 ->
+              loop Int64.(add next (of_int this_time))
+            | x -> return (`Ok x)
+      end in
+    loop 0L

lib/compare.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 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. *)

lib/copy.ml

@@ -14,9 +14,77 @@
  * 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 copy
   (type from) (module From: V1_LWT.BLOCK with type t = from) (from: from)
   (type dest) (module Dest: V1_LWT.BLOCK with type t = dest) (dest: dest) =
-  Lwt.return (`Error (`Msg "copy is not yet implemented"))
 
+  From.get_info from
+  >>= fun from_info ->
+  Dest.get_info dest
+  >>= fun dest_info ->
+
+  let total_size_from = Int64.(mul from_info.From.size_sectors (of_int from_info.From.sector_size)) in
+  let total_size_dest = Int64.(mul dest_info.Dest.size_sectors (of_int dest_info.Dest.sector_size)) in
+  if total_size_from <> total_size_dest
+  then return (`Error `Different_sizes)
+  else begin
+
+    (* We'll run multiple threads to try to overlap I/O *)
+    let next_from_sector = ref 0L in
+    let next_dest_sector = ref 0L in
+    let failure = ref None in
+    let m = Lwt_mutex.create () in
+
+    let record_failure e =
+      Lwt_mutex.with_lock m
+        (fun () -> match !failure with
+          | Some _ -> return ()
+          | None -> failure := Some e; return ()) in
+
+    let thread () =
+      (* A page-aligned 64KiB buffer *)
+      let buffer = Io_page.(to_cstruct (get 8)) in
+      let from_sectors = Cstruct.len buffer / from_info.From.sector_size in
+      let dest_sectors = Cstruct.len buffer / dest_info.Dest.sector_size in
+      let rec loop () =
+        Lwt_mutex.with_lock m (fun () ->
+          let next_from = !next_from_sector in
+          let next_dest = !next_dest_sector in
+          next_from_sector := Int64.(add next_from (of_int from_sectors));
+          next_dest_sector := Int64.(add next_dest (of_int dest_sectors));
+          return (next_from, next_dest)
+        ) >>= fun (next_from, next_dest) ->
+        if next_from >= from_info.From.size_sectors
+        then return ()
+        else begin
+          let remaining = Int64.(sub from_info.From.size_sectors next_from) in
+          let this_time = min from_sectors (Int64.to_int remaining) in
+          let buf = Cstruct.sub buffer 0 (from_info.From.sector_size * this_time) in
+          From.read from next_from [ buf ]
+          >>= function
+          | `Error e ->
+            record_failure (error_to_string e)
+          | `Ok () ->
+            Dest.write dest next_dest [ buf ]
+            >>= function
+            | `Error e ->
+              record_failure (error_to_string e)
+            | `Ok () ->
+              loop ()
+        end in
+      loop () in
+    let threads = List.map thread [ (); (); (); (); (); (); (); () ] in
+    Lwt.join threads
+    >>= fun () ->
+    match !failure with
+    | None -> return (`Ok ())
+    | Some msg -> return (`Error (`Msg msg))
+  end

lib/patterns.ml

@@ -0,0 +1,49 @@
+(*
+ * 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 random
+  (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 next =
+    if next >= info.Block.size_sectors
+    then return (`Ok ())
+    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
+      for i = 0 to Cstruct.len buf - 1 do
+        Cstruct.set_uint8 buf i (Random.int 256)
+      done;
+      Block.write b next [ buf ]
+      >>= function
+      | `Error e ->
+        return (`Error (`Msg (error_to_string e)))
+      | `Ok () ->
+        loop Int64.(add next (of_int this_time))
+    end in
+  loop 0L

lib/patterns.mli

@@ -0,0 +1,21 @@
+(*
+ * 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 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/ramdisk.ml

@@ -0,0 +1,101 @@
+(*
+ * Copyright (C) 2011-2013 Citrix Systems Inc
+ *
+ * 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
+
+type 'a io = 'a Lwt.t
+
+type id = string
+
+(* NB not actually page-aligned *)
+type page_aligned_buffer = Cstruct.t
+
+let alloc = Cstruct.create
+
+type error = [
+  | `Unknown of string
+  | `Unimplemented
+  | `Is_read_only
+  | `Disconnected ]
+
+type info = {
+  read_write: bool;
+  sector_size: int;
+  size_sectors: int64;
+}
+
+module Int64Map = Map.Make(Int64)
+
+type t = {
+  mutable map: page_aligned_buffer Int64Map.t;
+  info: info;
+  id: id;
+}
+
+let id t = t.id
+
+let devices = Hashtbl.create 1
+
+let get_info { info } = return info
+
+let create ~name ~size_sectors ~sector_size =
+  let map = Int64Map.empty in
+  let info = {
+    read_write = true;
+    size_sectors;
+    sector_size;
+  } in
+  let device = { map; info; id = name } in
+  Hashtbl.replace devices name device
+
+let destroy ~name = Hashtbl.remove devices name
+
+let connect ~name =
+  if Hashtbl.mem devices name
+  then return (`Ok (Hashtbl.find devices name))
+  else begin
+    create ~name ~size_sectors:32768L ~sector_size:512;
+    return (`Ok (Hashtbl.find devices name))
+  end
+
+let disconnect t =
+  return ()
+
+let rec read x sector_start buffers = match buffers with
+  | [] -> return (`Ok ())
+  | b :: bs ->
+    if Int64Map.mem sector_start x.map
+    then Cstruct.blit (Int64Map.find sector_start x.map) 0 b 0 512
+    else begin
+      for i = 0 to 511 do
+        Cstruct.set_uint8 b i 0
+      done
+    end;
+    read x (Int64.succ sector_start)
+      (if Cstruct.len b > 512
+       then (Cstruct.shift b 512) :: bs
+       else bs)
+
+let rec write x sector_start buffers = match buffers with
+  | [] -> return (`Ok ())
+  | b :: bs ->
+    if Cstruct.len b = 512 then begin
+      x.map <- Int64Map.add sector_start b x.map;
+      write x (Int64.succ sector_start) bs
+    end else begin
+      x.map <- Int64Map.add sector_start (Cstruct.sub b 0 512) x.map;
+      write x (Int64.succ sector_start) (Cstruct.shift b 512 :: bs)
+    end

lib/ramdisk.mli

@@ -0,0 +1,29 @@
+(*
+ * Copyright (C) 2011-2013 Citrix Systems Inc
+ *
+ * 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.
+ *)
+
+include V1_LWT.BLOCK
+  with type id = string
+
+val create: name:string -> size_sectors:int64 -> sector_size:int -> unit
+(** Create an in-memory block device (a "ramdisk") with a given name,
+    total size in sectors and sector size. Two calls to [connect] with the
+    same name will return the same block device *)
+
+val destroy: name:string -> unit
+(** Destroy removes an in-memory block device. Subsequent calls to
+    [connect] will create a fresh empty device. *)
+
+val connect: name:string -> [ `Ok of t | `Error of error ] Lwt.t