Use logs, check more interface constraints, add more tests

_oasis

@@ -12,7 +12,7 @@ Library mirage_block_unix
   Path:               lib
   Findlibname:        mirage-block-unix
   Modules:            Block
-  BuildDepends:       cstruct, lwt, lwt.unix, mirage-types
+  BuildDepends:       cstruct, lwt, lwt.unix, mirage-types, logs
   CSources:           odirect_stubs.c, blkgetsize_stubs.c, lseekhole_stubs.c
 
 Executable test

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: d4f9a33e602e829bcc54553c61e46a98)
+# DO NOT EDIT (digest: 97ab1a9e7e4e73f12d1b882549354770)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -18,25 +18,30 @@ true: annot, bin_annot
 "lib/mirage_block_unix.cmxs": use_mirage_block_unix
 <lib/mirage_block_unix.{cma,cmxa}>: use_libmirage_block_unix_stubs
 <lib/*.ml{,i,y}>: pkg_cstruct
+<lib/*.ml{,i,y}>: pkg_logs
 <lib/*.ml{,i,y}>: pkg_lwt
 <lib/*.ml{,i,y}>: pkg_lwt.unix
 <lib/*.ml{,i,y}>: pkg_mirage-types
 "lib/odirect_stubs.c": pkg_cstruct
+"lib/odirect_stubs.c": pkg_logs
 "lib/odirect_stubs.c": pkg_lwt
 "lib/odirect_stubs.c": pkg_lwt.unix
 "lib/odirect_stubs.c": pkg_mirage-types
 "lib/blkgetsize_stubs.c": pkg_cstruct
+"lib/blkgetsize_stubs.c": pkg_logs
 "lib/blkgetsize_stubs.c": pkg_lwt
 "lib/blkgetsize_stubs.c": pkg_lwt.unix
 "lib/blkgetsize_stubs.c": pkg_mirage-types
 "lib/lseekhole_stubs.c": pkg_cstruct
+"lib/lseekhole_stubs.c": pkg_logs
 "lib/lseekhole_stubs.c": pkg_lwt
 "lib/lseekhole_stubs.c": pkg_lwt.unix
 "lib/lseekhole_stubs.c": pkg_mirage-types
 # Executable test
 <lib_test/test.{native,byte}>: pkg_cstruct
 <lib_test/test.{native,byte}>: pkg_io-page
 <lib_test/test.{native,byte}>: pkg_io-page.unix
+<lib_test/test.{native,byte}>: pkg_logs
 <lib_test/test.{native,byte}>: pkg_lwt
 <lib_test/test.{native,byte}>: pkg_lwt.unix
 <lib_test/test.{native,byte}>: pkg_mirage-types
@@ -45,6 +50,7 @@ true: annot, bin_annot
 <lib_test/*.ml{,i,y}>: pkg_cstruct
 <lib_test/*.ml{,i,y}>: pkg_io-page
 <lib_test/*.ml{,i,y}>: pkg_io-page.unix
+<lib_test/*.ml{,i,y}>: pkg_logs
 <lib_test/*.ml{,i,y}>: pkg_lwt
 <lib_test/*.ml{,i,y}>: pkg_lwt.unix
 <lib_test/*.ml{,i,y}>: pkg_mirage-types

lib/META

@@ -1,8 +1,8 @@
 # OASIS_START
-# DO NOT EDIT (digest: 9605ad60470b87ad4265ebe638996635)
+# DO NOT EDIT (digest: 04a3ce53b0bf0d5e9a030733f4d3403d)
 version = "2.1.0"
 description = "Mirage block driver for Unix"
-requires = "cstruct lwt lwt.unix mirage-types"
+requires = "cstruct lwt lwt.unix mirage-types logs"
 archive(byte) = "mirage_block_unix.cma"
 archive(byte, plugin) = "mirage_block_unix.cma"
 archive(native) = "mirage_block_unix.cmxa"

lib/block.ml

@@ -14,6 +14,13 @@
  * PERFORMANCE OF THIS SOFTWARE.
  *)
 
+ let src =
+   let src = Logs.Src.create "mirage-block-unix" ~doc:"Mirage BLOCK interface for Unix" in
+   Logs.Src.set_level src (Some Logs.Info);
+   src
+
+ module Log = (val Logs.src_log src : Logs.LOG)
+
 type buf = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
 
 type id = string
@@ -75,6 +82,10 @@ module Result = struct
       `Error (`Unknown (Printf.sprintf "%s %s: %s" f' x' (Printexc.to_string e)))
 end
 
+let (>>*=) m f = m >>= function
+  | `Ok x -> f x
+  | `Error x -> Lwt.return (`Error x)
+
 let stat filename fd = Result.wrap_exn "stat" filename Unix.LargeFile.fstat fd
 let blkgetsize filename fd = Result.wrap_exn "BLKGETSIZE" filename Raw.blkgetsize fd
 
@@ -86,6 +97,7 @@ let get_file_size filename fd =
   | Unix.S_REG -> `Ok st.Unix.LargeFile.st_size
   | Unix.S_BLK -> blkgetsize filename fd
   | _ ->
+    Log.err (fun f -> f "get_file_size %s: entity is neither a file nor a block device" filename);
     `Error
       (`Unknown
          (Printf.sprintf "get_file_size %s: neither a file nor a block device" filename))
@@ -120,7 +132,8 @@ let connect name =
       let m = Lwt_mutex.create () in
       return (`Ok { fd = Some fd; m; name; info = { sector_size; size_sectors; read_write } })
   with e ->
-    return (`Error (`Unknown (Printf.sprintf "connect %s: failed to oppen file" name)))
+    Log.err (fun f -> f "connect %s: failed to open file" name);
+    return (`Error (`Unknown (Printf.sprintf "connect %s: failed to open file" name)))
 
 let disconnect t = match t.fd with
   | Some fd ->
@@ -152,24 +165,32 @@ let complete op fd buffer =
 let really_read = complete Lwt_bytes.read
 let really_write = complete Lwt_bytes.write
 
-let lwt_wrap_exn name op offset length f =
+let lwt_wrap_exn t op offset ?buffer f =
+  let fatalf fmt = Printf.ksprintf (fun s ->
+    Log.err (fun f -> f "%s" s);
+    return (`Error (`Unknown s))
+    ) fmt in
+  let describe_buffer = function
+    | None -> ""
+    | Some x -> "with buffer of length " ^ (string_of_int (Cstruct.len x)) in
+  (* Buffer must be a multiple of sectors in length *)
+  ( match buffer with
+    | None -> Lwt.return (`Ok ())
+    | Some b ->
+      let len = Cstruct.len b in
+      if len mod t.info.sector_size <> 0
+      then fatalf "%s: buffer length (%d) is not a multiple of sector_size (%d) for file %s" op len t.info.sector_size t.name
+      else Lwt.return (`Ok ())
+  ) >>*= fun () ->
   Lwt.catch f
     (function
       | End_of_file ->
-        return (`Error
-                  (`Unknown
-                     (Printf.sprintf "%s: End_of_file at file %s offset %Ld with length %d"
-                        op name offset length)))
+        fatalf "%s: End_of_file at file %s offset %Ld %s" op t.name offset (describe_buffer buffer)
       | Unix.Unix_error(code, fn, arg) ->
-        return (`Error
-                  (`Unknown
-                     (Printf.sprintf "%s: %s in %s '%s' at file %s offset %Ld with length %d"
-                        op (Unix.error_message code) fn arg name offset length)))
+        fatalf "%s: %s in %s '%s' at file %s offset %Ld %s" op (Unix.error_message code) fn arg t.name offset (describe_buffer buffer)
       | e ->
-        return (`Error
-                  (`Unknown
-                     (Printf.sprintf "%s: %s at file %s offset %Ld with length %d"
-                        op (Printexc.to_string e) name offset length))))
+        fatalf "%s: %s at file %s offset %Ld %s" op (Printexc.to_string e) t.name offset (describe_buffer buffer)
+    )
 
 let rec read x sector_start buffers = match buffers with
   | [] -> return (`Ok ())
@@ -178,7 +199,7 @@ let rec read x sector_start buffers = match buffers with
       | None -> return (`Error `Disconnected)
       | Some fd ->
         let offset = Int64.(mul sector_start (of_int x.info.sector_size))  in
-        lwt_wrap_exn x.name "read" offset (Cstruct.len b)
+        lwt_wrap_exn x "read" offset ~buffer:b
           (fun () ->
              if Int64.(add sector_start (of_int ((Cstruct.len b) / x.info.sector_size))) >
                 x.info.size_sectors then fail End_of_file else
@@ -203,7 +224,7 @@ let rec write x sector_start buffers = match buffers with
         return (`Error `Is_read_only)
       | { fd = Some fd } ->
         let offset = Int64.(mul sector_start (of_int x.info.sector_size)) in
-        lwt_wrap_exn x.name "write" offset (Cstruct.len b)
+        lwt_wrap_exn x "write" offset ~buffer:b
           (fun () ->
              if Int64.(add sector_start (of_int ((Cstruct.len b) / x.info.sector_size))) >
                 x.info.size_sectors then fail End_of_file else
@@ -225,7 +246,7 @@ let resize t new_size_sectors =
   match t.fd with
     | None -> return (`Error `Disconnected)
     | Some fd ->
-      lwt_wrap_exn t.name "ftruncate" new_size_bytes 0
+      lwt_wrap_exn t "ftruncate" new_size_bytes
         (fun () ->
           Lwt_unix.LargeFile.ftruncate fd new_size_bytes
           >>= fun () ->
@@ -237,7 +258,7 @@ let flush t =
   match t.fd with
     | None -> return (`Error `Disconnected)
     | Some fd ->
-      lwt_wrap_exn t.name "fsync" 0L 0
+      lwt_wrap_exn t "fsync" 0L
         (fun () ->
           Lwt_unix.fsync fd
           >>= fun () ->
@@ -249,7 +270,7 @@ let seek_mapped t from =
     | None -> return (`Error `Disconnected)
     | Some fd ->
       let offset = Int64.(mul from (of_int t.info.sector_size)) in
-      lwt_wrap_exn t.name "seek_mapped" offset 0
+      lwt_wrap_exn t "seek_mapped" offset
         (fun () ->
           Lwt_mutex.with_lock t.m
             (fun () ->
@@ -264,7 +285,7 @@ let seek_unmapped t from =
     | None -> return (`Error `Disconnected)
     | Some fd ->
       let offset = Int64.(mul from (of_int t.info.sector_size)) in
-      lwt_wrap_exn t.name "seek_unmapped" offset 0
+      lwt_wrap_exn t "seek_unmapped" offset
         (fun () ->
           Lwt_mutex.with_lock t.m
             (fun () ->

lib_test/test.ml

@@ -19,6 +19,13 @@ open Block
 open OUnit
 open Utils
 
+let or_failwith = function
+  | `Error (`Unknown msg) -> failwith msg
+  | `Error `Is_read_only -> failwith "Is_read_only"
+  | `Error `Unimplemented -> failwith "Unimplemented"
+  | `Error `Disconnected -> failwith "Disconnected"
+  | `Ok x -> x
+
 let test_enoent () =
   let t =
     let name = find_unused_file () in
@@ -76,6 +83,62 @@ let test_open_block () =
       ) in
   Lwt_main.run t
 
+let test_write_read () =
+  let t =
+    with_temp_file
+      (fun file ->
+        Block.connect file >>= function
+        | `Error _ -> failwith (Printf.sprintf "Block.connect %s failed" file)
+        | `Ok device1 ->
+          Block.get_info device1
+          >>= fun info1 ->
+          let sector = alloc info1.Block.sector_size in
+          let rec write x =
+            if x = 0 then Lwt.return (`Ok ()) else begin
+              Cstruct.memset sector x;
+              Block.write device1 (Int64.of_int x) [ sector ]
+              >>= fun r ->
+              let () = or_failwith r in
+              write (x - 1)
+            end in
+          write 255
+          >>= fun x ->
+          let () = or_failwith x in
+          let sector' = alloc info1.Block.sector_size in
+          let rec read x =
+            if x = 0 then Lwt.return (`Ok ()) else begin
+              Cstruct.memset sector' x;
+              Block.read device1 (Int64.of_int x) [ sector ]
+              >>= fun r ->
+              let () = or_failwith r in
+              if not(Cstruct.equal sector sector')
+              then failwith (Printf.sprintf "test_write_read: sector %d not equal" x);
+              read (x - 1)
+            end in
+          read 255
+          >>= fun x ->
+          let () = or_failwith x in
+          Lwt.return ()
+      ) in
+  Lwt_main.run t
+
+let test_buffer_wrong_length () =
+  let t =
+    with_temp_file
+      (fun file ->
+        Block.connect file >>= function
+        | `Error _ -> failwith (Printf.sprintf "Block.connect %s failed" file)
+        | `Ok device1 ->
+          Block.get_info device1
+          >>= fun info1 ->
+          let sector = alloc info1.Block.sector_size in
+          Block.write device1 0L [ Cstruct.shift sector 1 ]
+          >>= function
+          | `Error _ -> Lwt.return ()
+          | `Ok () -> failwith "a write with a bad length succeeded"
+      ) in
+  Lwt_main.run t
+
 let test_eof () =
   let t =
     let name = find_unused_file () in
@@ -149,5 +212,7 @@ let _ =
     "test read/write after last sector" >:: test_eof;
     "test resize" >:: test_resize;
     "test flush" >:: test_flush;
+    "test write then read" >:: test_write_read;
+    "test that writes fail if the buffer has a bad length" >:: test_buffer_wrong_length;
   ] in
   OUnit2.run_test_tt_main (ounit2_of_ounit1 suite)

opam

@@ -22,6 +22,7 @@ depends: [
   "lwt" {>= "2.4.3"}
   "mirage-types" {>= "1.1.0"}
   "io-page" {>= "1.0.0"}
+  "logs"
   "ounit" {test}
   "ocamlbuild" {build}
 ]

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.3.0 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 2992ccf0723881d50a46ba03d4c90167) *)
+(* DO NOT EDIT (digest: dcc355237b2bfe256a7f874b124e4540) *)
 (*
    Regenerated by OASIS v0.4.5
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -6929,7 +6929,8 @@ let setup_t =
                            FindlibPackage ("cstruct", None);
                            FindlibPackage ("lwt", None);
                            FindlibPackage ("lwt.unix", None);
-                           FindlibPackage ("mirage-types", None)
+                           FindlibPackage ("mirage-types", None);
+                           FindlibPackage ("logs", None)
                         ];
                       bs_build_tools = [ExternalTool "ocamlbuild"];
                       bs_c_sources =
@@ -7028,14 +7029,14 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.5";
-     oasis_digest = Some "85D�X\027\012\158�\006���\000i";
+     oasis_digest = Some "1\018\"�\014B\031��\012r�qsy\150";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
   };;
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 7040 "setup.ml"
+# 7041 "setup.ml"
 (* OASIS_STOP *)
 let () = setup ();;