mirrors/guru
1
0
Fork 0
mirror of https://github.com/gentoo-mirror/guru.git synced 2026-07-15 01:53:25 -04:00
Code Issues Packages Projects Releases Wiki Activity
Files
43f48035e71c3effeee74f9fcc706bdfd8a8a969
guru/dev-ml/shared-block-ring/files/shared-block-ring-3.0.0-PR-62.patch
Alessandro Barbieri de35a48b09 dev-ml/shared-block-ring: initial import 
Signed-off-by: Alessandro Barbieri <lssndrbarbieri@gmail.com>
2022-04-15 22:34:20 +02:00

319 lines
12 KiB
Diff
Raw Blame History

From 4c8fb45a201cd15aa038d84bd792679a31bec5a8 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
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 <hannes@mehnert.org>
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 <hannes@mehnert.org>
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"
Reference in New Issue View Git Blame Copy Permalink