From 906d88085769aefbcea70cfa674c1d5fd176abb9 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 6 Mar 2016 15:35:18 +0000 Subject: [PATCH 1/8] Add dependency on logs, log error conditions On fatal errors (i.e. those which return a useless `Error string), we write a log message. Applications nolonger need to extract the `Error string and log it themselves. Signed-off-by: David Scott --- _oasis | 2 +- lib/block.ml | 14 +++++++++++++- opam | 1 + 3 files changed, 15 insertions(+), 2 deletions(-) diff --git a/_oasis b/_oasis index 49be3d5..4517825 100644 --- a/_oasis +++ b/_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 diff --git a/lib/block.ml b/lib/block.ml index 068415d..b7f86fb 100644 --- a/lib/block.ml +++ b/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 @@ -86,6 +93,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 +128,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 -> @@ -156,16 +165,19 @@ let lwt_wrap_exn name op offset length f = Lwt.catch f (function | End_of_file -> + Log.info (fun f -> f "%s: End_of_file at file %s offset %Ld with length %d" op name offset length); return (`Error (`Unknown (Printf.sprintf "%s: End_of_file at file %s offset %Ld with length %d" op name offset length))) | Unix.Unix_error(code, fn, arg) -> + Log.err (fun f -> f "%s: %s in %s '%s' at file %s offset %Ld with length %d" op (Unix.error_message code) fn arg name offset length); 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))) | e -> + Log.err (fun f -> f "%s: %s at file %s offset %Ld with length %d" op (Printexc.to_string e) name offset length); return (`Error (`Unknown (Printf.sprintf "%s: %s at file %s offset %Ld with length %d" diff --git a/opam b/opam index 59002a9..9602c06 100644 --- a/opam +++ b/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} ] From 09a3c5a6de6be0eea7266701d25b2f8bd2c03d12 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 6 Mar 2016 15:37:47 +0000 Subject: [PATCH 2/8] Regenerate OASIS Signed-off-by: David Scott --- _tags | 8 +++++++- lib/META | 4 ++-- setup.ml | 9 +++++---- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/_tags b/_tags index 9bb7a3a..fae600f 100644 --- a/_tags +++ b/_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,18 +18,22 @@ true: annot, bin_annot "lib/mirage_block_unix.cmxs": use_mirage_block_unix : use_libmirage_block_unix_stubs : pkg_cstruct +: pkg_logs : pkg_lwt : pkg_lwt.unix : 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 @@ -37,6 +41,7 @@ true: annot, bin_annot : pkg_cstruct : pkg_io-page : pkg_io-page.unix +: pkg_logs : pkg_lwt : pkg_lwt.unix : pkg_mirage-types @@ -45,6 +50,7 @@ true: annot, bin_annot : pkg_cstruct : pkg_io-page : pkg_io-page.unix +: pkg_logs : pkg_lwt : pkg_lwt.unix : pkg_mirage-types diff --git a/lib/META b/lib/META index 53160d7..a97e8de 100644 --- a/lib/META +++ b/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" diff --git a/setup.ml b/setup.ml index be23f78..cff6775 100644 --- a/setup.ml +++ b/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,7 +7029,7 @@ 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 @@ -7036,6 +7037,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7040 "setup.ml" +# 7041 "setup.ml" (* OASIS_STOP *) let () = setup ();; From b6fd4cc1db741af9bec5899b58c98c24fcf21cbb Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 6 Mar 2016 15:40:57 +0000 Subject: [PATCH 3/8] lwt_wrap_exn should take a `type t` argument Before this patch we only passed in the filename, for logging purposes. We want to check alignment invariants, so we will need the full `t`. Signed-off-by: David Scott --- lib/block.ml | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/lib/block.ml b/lib/block.ml index b7f86fb..d83d002 100644 --- a/lib/block.ml +++ b/lib/block.ml @@ -161,27 +161,27 @@ 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 length f = Lwt.catch f (function | End_of_file -> - Log.info (fun f -> f "%s: End_of_file at file %s offset %Ld with length %d" op name offset length); + Log.info (fun f -> f "%s: End_of_file at file %s offset %Ld with length %d" op t.name offset length); return (`Error (`Unknown (Printf.sprintf "%s: End_of_file at file %s offset %Ld with length %d" - op name offset length))) + op t.name offset length))) | Unix.Unix_error(code, fn, arg) -> - Log.err (fun f -> f "%s: %s in %s '%s' at file %s offset %Ld with length %d" op (Unix.error_message code) fn arg name offset length); + Log.err (fun f -> f "%s: %s in %s '%s' at file %s offset %Ld with length %d" op (Unix.error_message code) fn arg t.name offset length); 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))) + op (Unix.error_message code) fn arg t.name offset length))) | e -> - Log.err (fun f -> f "%s: %s at file %s offset %Ld with length %d" op (Printexc.to_string e) name offset length); + Log.err (fun f -> f "%s: %s at file %s offset %Ld with length %d" op (Printexc.to_string e) t.name offset length); return (`Error (`Unknown (Printf.sprintf "%s: %s at file %s offset %Ld with length %d" - op (Printexc.to_string e) name offset length)))) + op (Printexc.to_string e) t.name offset length)))) let rec read x sector_start buffers = match buffers with | [] -> return (`Ok ()) @@ -190,7 +190,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 (Cstruct.len 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 @@ -215,7 +215,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 (Cstruct.len 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 @@ -237,7 +237,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 0 (fun () -> Lwt_unix.LargeFile.ftruncate fd new_size_bytes >>= fun () -> @@ -249,7 +249,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 0 (fun () -> Lwt_unix.fsync fd >>= fun () -> @@ -261,7 +261,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 0 (fun () -> Lwt_mutex.with_lock t.m (fun () -> @@ -276,7 +276,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 0 (fun () -> Lwt_mutex.with_lock t.m (fun () -> From 127c02f52ad8148ae0e35bb101d6fb45770c7cf4 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 6 Mar 2016 15:44:20 +0000 Subject: [PATCH 4/8] Define and use a convience function `fatalf` inside `lwt_wrap_exn` Since we always used `Log` to log the error, before returning it as an `Error string, define and use a new function `fatalf` to do both at once. Note before we actuallly logged `End_of_file` as "info" but this was probably a mistake, since it too returned `Error string. Signed-off-by: David Scott --- lib/block.ml | 23 ++++++++--------------- 1 file changed, 8 insertions(+), 15 deletions(-) diff --git a/lib/block.ml b/lib/block.ml index d83d002..fbc1e48 100644 --- a/lib/block.ml +++ b/lib/block.ml @@ -162,26 +162,19 @@ let really_read = complete Lwt_bytes.read let really_write = complete Lwt_bytes.write let lwt_wrap_exn t op offset length f = + let fatalf fmt = Printf.ksprintf (fun s -> + Log.err (fun f -> f "%s" s); + return (`Error (`Unknown s)) + ) fmt in Lwt.catch f (function | End_of_file -> - Log.info (fun f -> f "%s: End_of_file at file %s offset %Ld with length %d" op t.name offset length); - return (`Error - (`Unknown - (Printf.sprintf "%s: End_of_file at file %s offset %Ld with length %d" - op t.name offset length))) + fatalf "%s: End_of_file at file %s offset %Ld with length %d" op t.name offset length | Unix.Unix_error(code, fn, arg) -> - Log.err (fun f -> f "%s: %s in %s '%s' at file %s offset %Ld with length %d" op (Unix.error_message code) fn arg t.name offset length); - 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 t.name offset length))) + fatalf "%s: %s in %s '%s' at file %s offset %Ld with length %d" op (Unix.error_message code) fn arg t.name offset length | e -> - Log.err (fun f -> f "%s: %s at file %s offset %Ld with length %d" op (Printexc.to_string e) t.name offset length); - return (`Error - (`Unknown - (Printf.sprintf "%s: %s at file %s offset %Ld with length %d" - op (Printexc.to_string e) t.name offset length)))) + fatalf "%s: %s at file %s offset %Ld with length %d" op (Printexc.to_string e) t.name offset length + ) let rec read x sector_start buffers = match buffers with | [] -> return (`Ok ()) From c4debcb4508bdb4eb374bd02a25bd2a286aeb08d Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 6 Mar 2016 15:50:40 +0000 Subject: [PATCH 5/8] lwt_wrap_exn: pass an optional buffer, not a non-optional length Before this patch several callers had no buffer to operate on so they artifically used a length of 0. This patch makes the buffer into an optional argument so these callers will simply use the default value of None. Signed-off-by: David Scott --- lib/block.ml | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/lib/block.ml b/lib/block.ml index fbc1e48..796d63a 100644 --- a/lib/block.ml +++ b/lib/block.ml @@ -161,19 +161,22 @@ let complete op fd buffer = let really_read = complete Lwt_bytes.read let really_write = complete Lwt_bytes.write -let lwt_wrap_exn t 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 Lwt.catch f (function | End_of_file -> - fatalf "%s: End_of_file at file %s offset %Ld with length %d" op t.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) -> - fatalf "%s: %s in %s '%s' at file %s offset %Ld with length %d" op (Unix.error_message code) fn arg t.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 -> - fatalf "%s: %s at file %s offset %Ld with length %d" op (Printexc.to_string e) t.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 @@ -183,7 +186,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 "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 @@ -208,7 +211,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 "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 @@ -230,7 +233,7 @@ let resize t new_size_sectors = match t.fd with | None -> return (`Error `Disconnected) | Some fd -> - lwt_wrap_exn t "ftruncate" new_size_bytes 0 + lwt_wrap_exn t "ftruncate" new_size_bytes (fun () -> Lwt_unix.LargeFile.ftruncate fd new_size_bytes >>= fun () -> @@ -242,7 +245,7 @@ let flush t = match t.fd with | None -> return (`Error `Disconnected) | Some fd -> - lwt_wrap_exn t "fsync" 0L 0 + lwt_wrap_exn t "fsync" 0L (fun () -> Lwt_unix.fsync fd >>= fun () -> @@ -254,7 +257,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 "seek_mapped" offset 0 + lwt_wrap_exn t "seek_mapped" offset (fun () -> Lwt_mutex.with_lock t.m (fun () -> @@ -269,7 +272,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 "seek_unmapped" offset 0 + lwt_wrap_exn t "seek_unmapped" offset (fun () -> Lwt_mutex.with_lock t.m (fun () -> From 5893ca06410cb69c7e9be46dd93f0157fbad19c0 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 6 Mar 2016 16:15:27 +0000 Subject: [PATCH 6/8] Buffers must be a multiple of sector_size in length Before this patch the I/O would fail with an EINVAL, leaving the developer to wonder what went wrong. This patch logs and returns a descriptive error message. Signed-off-by: David Scott --- lib/block.ml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/lib/block.ml b/lib/block.ml index 796d63a..adb55bc 100644 --- a/lib/block.ml +++ b/lib/block.ml @@ -82,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 @@ -169,6 +173,15 @@ let lwt_wrap_exn t op offset ?buffer f = 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 -> From 3a61f0c7cdc0b86b3816eb046b66ec5eb8a9b928 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 6 Mar 2016 16:38:43 +0000 Subject: [PATCH 7/8] test: check we can read back patterns we write This is a very simple test which writes sectors full of byte x to sector x for the first 255 sectors, and then reads them back again. Signed-off-by: David Scott --- lib_test/test.ml | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/lib_test/test.ml b/lib_test/test.ml index e03454a..71f0eb0 100644 --- a/lib_test/test.ml +++ b/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,46 @@ 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_eof () = let t = let name = find_unused_file () in @@ -149,5 +196,6 @@ let _ = "test read/write after last sector" >:: test_eof; "test resize" >:: test_resize; "test flush" >:: test_flush; + "test write then read" >:: test_write_read; ] in OUnit2.run_test_tt_main (ounit2_of_ounit1 suite) From 7737e58516b9605c92e8ef79f70a9b9cc7f35ab1 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 6 Mar 2016 16:43:14 +0000 Subject: [PATCH 8/8] Add a test for writes with bad buffer lengths Buffers should have a length equal to a multiple of sector sizes; check that errors are returned in this case. Signed-off-by: David Scott --- lib_test/test.ml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/lib_test/test.ml b/lib_test/test.ml index 71f0eb0..0002b8f 100644 --- a/lib_test/test.ml +++ b/lib_test/test.ml @@ -122,6 +122,22 @@ let test_write_read () = ) 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 = @@ -197,5 +213,6 @@ let _ = "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)