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/_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/lib/block.ml b/lib/block.ml index 068415d..adb55bc 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 @@ -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 () -> diff --git a/lib_test/test.ml b/lib_test/test.ml index e03454a..0002b8f 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,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) 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} ] 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 ();;