From 4c8fb45a201cd15aa038d84bd792679a31bec5a8 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 27 Jan 2022 16:24:42 +0100 Subject: [PATCH 1/3] avoid deprecated Cstruct.len, use Cstruct.length instead --- a/lib/eraseBlock.ml +++ b/lib/eraseBlock.ml @@ -23,14 +23,14 @@ module Make(B: S.BLOCK) = struct >>= fun info -> let pages = Io_page.get block_size_pages in let buffer = Io_page.to_cstruct pages in - for i = 0 to Cstruct.len buffer - 1 do + for i = 0 to Cstruct.length buffer - 1 do Cstruct.set_char buffer i (pattern.[i mod (String.length pattern)]) done; let rec loop n = if n = info.Mirage_block.size_sectors then return (Ok ()) else - let buffer_in_sectors = Cstruct.len buffer / info.Mirage_block.sector_size in + let buffer_in_sectors = Cstruct.length buffer / info.Mirage_block.sector_size in let needed = Int64.to_int (min (Int64.sub info.Mirage_block.size_sectors n) (Int64.of_int buffer_in_sectors)) in let towrite = Cstruct.sub buffer 0 (needed * info.Mirage_block.sector_size) in B.write t n [ towrite ] --- a/lib/ring.ml +++ b/lib/ring.ml @@ -34,7 +34,7 @@ let minimum_size_sectors = Int64.add sector_data 1L let magic = Printf.sprintf "mirage shared-block-device 1.0" let zero buf = - for i = 0 to Cstruct.len buf - 1 do + for i = 0 to Cstruct.length buf - 1 do Cstruct.set_uint8 buf i 0 done @@ -357,7 +357,7 @@ module Producer = struct let open ResultM in let _sector = alloc t.info.Mirage_block.sector_size in (* add a 4 byte header of size, and round up to the next 4-byte offset *) - let needed_bytes = Int64.(logand (lognot 3L) (add 7L (of_int (Cstruct.len item)))) in + let needed_bytes = Int64.(logand (lognot 3L) (add 7L (of_int (Cstruct.length item)))) in let first_sector = Int64.(div t.producer.producer (of_int t.info.Mirage_block.sector_size)) in let first_offset = Int64.(to_int (rem t.producer.producer (of_int t.info.Mirage_block.sector_size))) in @@ -365,23 +365,23 @@ module Producer = struct the first page as it's only a 4-byte integer and we're padding to 4-byte offsets. *) read_modify_write t first_sector (fun sector -> (* Write the header and anything else we can *) - Cstruct.LE.set_uint32 sector first_offset (Int32.of_int (Cstruct.len item)); + Cstruct.LE.set_uint32 sector first_offset (Int32.of_int (Cstruct.length item)); if first_offset + 4 = t.info.Mirage_block.sector_size then item (* We can't write anything else, so just return the item *) else begin - let this = min (t.info.Mirage_block.sector_size - first_offset - 4) (Cstruct.len item) in + let this = min (t.info.Mirage_block.sector_size - first_offset - 4) (Cstruct.length item) in Cstruct.blit item 0 sector (first_offset + 4) this; Cstruct.shift item this end) >>= fun remaining -> let rec loop offset remaining = - if Cstruct.len remaining = 0 + if Cstruct.length remaining = 0 then return () else begin read_modify_write t offset (fun sector -> - let this = min t.info.Mirage_block.sector_size (Cstruct.len remaining) in + let this = min t.info.Mirage_block.sector_size (Cstruct.length remaining) in let frag = Cstruct.sub sector 0 this in - Cstruct.blit remaining 0 frag 0 (Cstruct.len frag); + Cstruct.blit remaining 0 frag 0 (Cstruct.length frag); Cstruct.shift remaining this) >>= fun remaining -> loop (Int64.succ offset) remaining end in @@ -408,7 +408,7 @@ module Producer = struct (fun () -> let item = Item.to_cstruct item in (* every item has a 4 byte header *) - let needed_bytes = Int64.(add 4L (of_int (Cstruct.len item))) in + let needed_bytes = Int64.(add 4L (of_int (Cstruct.length item))) in let open C in let open ResultM in ok_to_write t needed_bytes @@ -535,10 +535,10 @@ module Consumer = struct let frag = Cstruct.sub sector (4 + first_offset) this in Cstruct.blit frag 0 result 0 this; let rec loop consumer remaining = - if Cstruct.len remaining = 0 + if Cstruct.length remaining = 0 then return () else - let this = min t.info.Mirage_block.sector_size (Cstruct.len remaining) in + let this = min t.info.Mirage_block.sector_size (Cstruct.length remaining) in let frag = Cstruct.sub remaining 0 this in read Int64.(add sector_data (rem consumer total_sectors)) t.disk sector >>= fun () -> Cstruct.blit sector 0 frag 0 this; @@ -547,7 +547,7 @@ module Consumer = struct (* Read the payload before updating the consumer pointer *) let needed_bytes = Int64.(logand (lognot 3L) (add 7L (of_int (len)))) in match Item.of_cstruct result with - | None -> Lwt.return (Error (`Msg (Printf.sprintf "Failed to parse queue item: (%d)[%s]" (Cstruct.len result) (String.escaped (Cstruct.to_string result))))) + | None -> Lwt.return (Error (`Msg (Printf.sprintf "Failed to parse queue item: (%d)[%s]" (Cstruct.length result) (String.escaped (Cstruct.to_string result))))) | Some result -> return (Int64.(add t.consumer.consumer needed_bytes),result) end --- a/lib_test/test.ml +++ b/lib_test/test.ml @@ -47,7 +47,7 @@ let alloc sector_size = sector let fill_with_message buffer message = - for i = 0 to Cstruct.len buffer - 1 do + for i = 0 to Cstruct.length buffer - 1 do Cstruct.set_char buffer i (message.[i mod (String.length message)]) done --- a/shared-block-ring.opam +++ b/shared-block-ring.opam @@ -13,7 +13,7 @@ depends: [ "ocaml" {>= "4.06.0"} "bisect_ppx" {dev & >= "2.5.0"} "cmdliner" - "cstruct" {>= "3.0.0"} + "cstruct" {>= "6.0.0"} "dune" {>= "2.7.0"} "duration" "io-page" From f0b61e87f809dce36fb93e31349d02d9a679253a Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 27 Jan 2022 16:26:39 +0100 Subject: [PATCH 2/3] adapt to mirage-block 3.0.0 changes --- a/lib/ring.ml +++ b/lib/ring.ml @@ -92,14 +92,12 @@ module Common(Log: S.LOG)(B: S.BLOCK) = struct m >>= function | Error `Is_read_only -> Lwt.return (Error `Is_read_only) | Error `Disconnected -> Lwt.return (Error `Disconnected) - | Error `Unimplemented -> Lwt.return (Error `Unimplemented) | Error x -> Lwt.return (Error x) | Ok x -> f x let to_msg m = let open Lwt.Infix in m >>= function | Error `Disconnected -> Lwt.return (Error (`Msg "BLOCK device has already disconnected")) - | Error `Unimplemented -> Lwt.return (Error (`Msg "BLOCK function is unimplemented")) | Error `Is_read_only -> Lwt.return (Error (`Msg "BLOCK device is read-only")) | Error _ -> Lwt.return (Error (`Msg "Unknown error from BLOCK device")) | Ok x -> Lwt.return (Ok x) @@ -110,14 +108,12 @@ module Common(Log: S.LOG)(B: S.BLOCK) = struct let open Lwt.Infix in m >>= function | Error `Disconnected -> Lwt.return (Error `Disconnected) - | Error `Unimplemented -> Lwt.return (Error `Unimplemented) | Error x -> Lwt.return (Error x) | Ok x -> f x let to_msg m = let open Lwt.Infix in m >>= function | Error `Disconnected -> Lwt.return (Error (`Msg "BLOCK device has already disconnected")) - | Error `Unimplemented -> Lwt.return (Error (`Msg "BLOCK function is unimplemented")) | Error _ -> Lwt.return (Error (`Msg "Unknown error from BLOCK device")) | Ok x -> Lwt.return (Ok x) let return x = Lwt.return (Ok x) --- a/shared-block-ring.opam +++ b/shared-block-ring.opam @@ -21,8 +21,8 @@ depends: [ "logs" "lwt" "lwt_log" - "mirage-block" {>= "2.0.1"} - "mirage-block-unix" + "mirage-block" {>= "3.0.0"} + "mirage-block-unix" {>= "2.13.0"} "mirage-clock" {>= "3.0.0"} "mirage-clock-unix" {with-test} "mirage-time" {>= "2.0.1"} From 1c99469a8f6ce12455c1e5e27c54eb5fe5611251 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 11 Apr 2022 11:18:01 +0200 Subject: [PATCH 3/3] update to cmdliner 1.1.0, remove io-page-unix dependency --- a/example/dune +++ b/example/dune @@ -6,7 +6,6 @@ cmdliner cstruct io-page - io-page-unix logs logs.fmt logs.lwt --- a/example/main.ml +++ b/example/main.ml @@ -171,8 +171,10 @@ let produce_cmd = `S "DESCRIPTION"; `P "Read lines of text from stdin and push them as individual items onto the ring."; ] @ help in - Term.(ret(pure produce $ filename $ interval)), - Term.info "produce" ~doc ~man + let term = Term.(ret(const produce $ filename $ interval)) + and info = Cmd.info "produce" ~doc ~man + in + Cmd.v info term let consume_cmd = let doc = "Pop data from the ring" in @@ -180,8 +182,10 @@ let consume_cmd = `S "DESCRIPTION"; `P "Read lines of text from the ring and print them to stdout."; ] @ help in - Term.(ret(pure consume $ filename $ interval)), - Term.info "consume" ~doc ~man + let term = Term.(ret(const consume $ filename $ interval)) + and info = Cmd.info "consume" ~doc ~man + in + Cmd.v info term let create_cmd = let doc = "Create an empty ring" in @@ -189,8 +193,10 @@ let create_cmd = `S "DESCRIPTION"; `P "Initialise a device or file with an empty ring." ] @ help in - Term.(ret(pure create $ filename)), - Term.info "create" ~doc ~man + let term = Term.(ret(const create $ filename)) + and info = Cmd.info "create" ~doc ~man + in + Cmd.v info term let diagnostics_cmd = let doc = "Display the current state of a ring." in @@ -199,8 +205,10 @@ let diagnostics_cmd = `P "Display the current ring state including producer and consumer pointers, together with the current ring contents for diagnostic purposes."; `P "Note: the ring will not be modified." ] @ help in - Term.(ret(pure diagnostics $ filename)), - Term.info "diagnostics" ~doc ~man + let term = Term.(ret(const diagnostics $ filename)) + and info = Cmd.info "diagnostics" ~doc ~man + in + Cmd.v info term let suspend_cmd = let doc = "Suspend the ring." in @@ -208,8 +216,10 @@ let suspend_cmd = `S "DESCRIPTION"; `P "Perform a co-operative suspend of the ring. Once finished, the producer will have acknowledged and promise not to send any more data."; ] @ help in - Term.(ret(pure suspend $ filename)), - Term.info "suspend" ~doc ~man + let term = Term.(ret(const suspend $ filename)) + and info = Cmd.info "suspend" ~doc ~man + in + Cmd.v info term let resume_cmd = let doc = "Resume the ring." in @@ -217,19 +227,19 @@ let resume_cmd = `S "DESCRIPTION"; `P "Perform a co-operative resume of the ring. Once finished, the producer will have acknowledged and will be able to produce data."; ] @ help in - Term.(ret(pure resume $ filename)), - Term.info "resume" ~doc ~man + let term = Term.(ret(const resume $ filename)) + and info = Cmd.info "resume" ~doc ~man + in + Cmd.v info term -let default_cmd = - let doc = "manipulate shared rings on block devices" in - let man = help in - Term.(ret (pure (`Help (`Pager, None)))), - Term.info (Sys.argv.(0)) ~version:"1.0.0" ~doc ~man +let default_cmd = Term.(ret (const (`Help (`Pager, None)))) let cmds = [create_cmd; produce_cmd; consume_cmd; suspend_cmd; resume_cmd; diagnostics_cmd] -let _ = +let () = Logs.set_reporter (Logs_fmt.reporter ()); - match Term.eval_choice default_cmd cmds with - | `Error _ -> exit 1 - | _ -> exit 0 + let doc = "manipulate shared rings on block devices" in + let man = help in + let info = Cmd.info (Sys.argv.(0)) ~version:"%%VERSION%%" ~doc ~man in + let group = Cmd.group ~default:default_cmd info cmds in + exit (Cmd.eval group) --- a/lib_test/dune +++ b/lib_test/dune @@ -4,7 +4,6 @@ cstruct duration io-page - io-page-unix logs logs.fmt logs.lwt --- a/shared-block-ring.opam +++ b/shared-block-ring.opam @@ -12,12 +12,11 @@ bug-reports: "https://github.com/mirage/shared-block-ring/issues/" depends: [ "ocaml" {>= "4.06.0"} "bisect_ppx" {dev & >= "2.5.0"} - "cmdliner" + "cmdliner" {>= "1.1.0"} "cstruct" {>= "6.0.0"} "dune" {>= "2.7.0"} "duration" - "io-page" - "io-page-unix" {>= "2.0.0"} + "io-page" {>= "2.4.0"} "logs" "lwt" "lwt_log"