[Libguestfs] [PATCH libnbd 2/2] ocaml: Add NBD.with_handle utility function

Richard W.M. Jones
Sat, 11 Dec 2021 13:41:06 -0000

NBD.with_handle (fun nbd -> ...)

calls the inner function with a newly created handle, and ensures that
NBD.close is always called even if the inner function throws an
exception.

This is inspired by Laszlo Ersek's similar function added to virt-v2v
lib/utils.ml in the commit below.  Unlike that, this does not abstract
the connection and does not call NBD.shutdown.

https://github.com/libguestfs/virt-v2v/commit/b4a8ccf00f1364d703c6d5cf1fd77850105fdd65

I adjusted one example and a few of the tests to use this function.
It is not really necessary to use it, so having a mix of both styles
seems reasonable.
---
 generator/OCaml.ml                       | 15 +++++
 ocaml/examples/extents.ml                | 66 ++++++++++----------
 ocaml/libnbd-ocaml.pod                   | 15 +++++
 ocaml/tests/Makefile.am                  |  3 +
 ocaml/tests/test_105_with_handle.ml      | 37 ++++++++++++
 ocaml/tests/test_110_defaults.ml         | 28 +++++----
 ocaml/tests/test_120_set_non_defaults.ml | 76 ++++++++++++------------
 ocaml/tests/test_200_connect_command.ml  |  9 ++-
 ocaml/tests/test_400_pread.ml            | 16 +++--
 9 files changed, 174 insertions(+), 91 deletions(-)

diff --git a/generator/OCaml.ml b/generator/OCaml.ml
index 1349609bd..4e901648a 100644
--- a/generator/OCaml.ml
+++ b/generator/OCaml.ml
@@ -225,6 +225,17 @@ val close : t -> unit
     immediately.
 *)

+val with_handle : (t -> 'a) -> 'a
+(** Wrapper around {!create}.  It calls the function parameter with a
+    newly created handle, and ensures that {!close} is always called
+    even if the function throws an exception.
+
+    Use this when it is essential that the handle is closed in order
+    to free up external resources in a timely manner; for example if
+    running the server as a subprocess and you want to ensure that the
+    subprocess is always killed; or if you need to disconnect from the
+    server before continuing with another operation. *)
+
 ";

   List.iter (
@@ -315,6 +326,10 @@ type t
 external create : unit -> t = \"nbd_internal_ocaml_nbd_create\"
 external close : t -> unit = \"nbd_internal_ocaml_nbd_close\"

+let with_handle f +  let nbd = create () in
+  try let r = f nbd in close nbd; r with exn -> close nbd; raise exn
+
 ";

   List.iter (
diff --git a/ocaml/examples/extents.ml b/ocaml/examples/extents.ml
index e4422b270..58b4d56cb 100644
--- a/ocaml/examples/extents.ml
+++ b/ocaml/examples/extents.ml
@@ -1,36 +1,38 @@
 open Printf

 let () -  let nbd = NBD.create () in
-  NBD.add_meta_context nbd "base:allocation";
-  NBD.connect_command nbd
-                      ["nbdkit"; "-s";
"--exit-with-parent"; "-r";
-                       "sparse-random"; "8G"];
+  NBD.with_handle (
+    fun nbd ->
+      NBD.add_meta_context nbd "base:allocation";
+      NBD.connect_command nbd
+                          ["nbdkit"; "-s";
"--exit-with-parent"; "-r";
+                           "sparse-random"; "8G"];

-  (* Read the extents and print them. *)
-  let size = NBD.get_size nbd in
-  let fetch_offset = ref 0_L in
-  while !fetch_offset < size do
-    let remaining = Int64.sub size !fetch_offset in
-    let fetch_size = min remaining 0x8000_0000_L in
-    NBD.block_status nbd fetch_size !fetch_offset (
-      fun meta _ entries err ->
-        printf "nbd_block_status callback: meta=%s err=%d\n" meta
!err;
-        if meta = "base:allocation" then (
-          printf "index\t%-20s %-20s %s\n" "offset"
"length" "flags";
-          for i = 0 to Array.length entries / 2 - 1 do
-            let len = Int64.of_int32 entries.(i*2)
-            and flags -              match entries.(i*2+1) with
-              | 0_l -> "data"
-              | 1_l -> "hole"
-              | 2_l -> "zero"
-              | 3_l -> "hole+zero"
-              | i -> sprintf "unknown (%ld)" i in
-            printf "%d:\t%-20Ld %-20Ld %s\n" i !fetch_offset len
flags;
-            fetch_offset := Int64.add !fetch_offset len
-          done;
-        );
-        0
-    ) (* NBD.block_status *)
-  done
+      (* Read the extents and print them. *)
+      let size = NBD.get_size nbd in
+      let fetch_offset = ref 0_L in
+      while !fetch_offset < size do
+        let remaining = Int64.sub size !fetch_offset in
+        let fetch_size = min remaining 0x8000_0000_L in
+        NBD.block_status nbd fetch_size !fetch_offset (
+          fun meta _ entries err ->
+            printf "nbd_block_status callback: meta=%s err=%d\n" meta
!err;
+            if meta = "base:allocation" then (
+              printf "index\t%-20s %-20s %s\n" "offset"
"length" "flags";
+              for i = 0 to Array.length entries / 2 - 1 do
+                let len = Int64.of_int32 entries.(i*2)
+                and flags +                  match entries.(i*2+1) with
+                  | 0_l -> "data"
+                  | 1_l -> "hole"
+                  | 2_l -> "zero"
+                  | 3_l -> "hole+zero"
+                  | i -> sprintf "unknown (%ld)" i in
+                printf "%d:\t%-20Ld %-20Ld %s\n" i !fetch_offset len
flags;
+                fetch_offset := Int64.add !fetch_offset len
+              done;
+            );
+            0
+        ) (* NBD.block_status *)
+      done
+  )
diff --git a/ocaml/libnbd-ocaml.pod b/ocaml/libnbd-ocaml.pod
index 19825805b..ebcce37cf 100644
--- a/ocaml/libnbd-ocaml.pod
+++ b/ocaml/libnbd-ocaml.pod
@@ -7,6 +7,18 @@ libnbd-ocaml - how to use libnbd from OCaml
  let nbd = NBD.create () in
  NBD.connect_uri nbd "nbd://localhost";
  let size = NBD.get_size nbd in
+ printf "%Ld\n" size;
+ NBD.close ()
+
+Alternate syntax which ensures that close is called even if an
+exception is thrown:
+
+ let size +   NBD.with_handle (
+     fun nbd ->
+       NBD.connect_uri nbd "nbd://localhost";
+       NBD.get_size nbd
+   ) in
  printf "%Ld\n" size

 To compile:
@@ -36,6 +48,9 @@ it will be closed automatically when it is garbage collected.
If you
 call any other method on a handle which you have explicitly closed
 then the API will throw an C<NBD.Closed> exception.

+C<NBD.with_handle> can be used to make sure the handle is closed in a
+timely manner.  See the example in the L</SYNOPSIS> above.
+
 =head1 ERRORS

 Libnbd errors are turned automatically into S<C<NBD.Error (str,
errno)>>
diff --git a/ocaml/tests/Makefile.am b/ocaml/tests/Makefile.am
index 6fac8b7c4..b89e807cc 100644
--- a/ocaml/tests/Makefile.am
+++ b/ocaml/tests/Makefile.am
@@ -22,6 +22,7 @@ CLEANFILES += *.annot *.cmi *.cmo *.cmx *.o *.a *.so *.bc
*.opt
 EXTRA_DIST = \
 	test_010_import.ml \
 	test_100_handle.ml \
+	test_105_with_handle.ml \
 	test_110_defaults.ml \
 	test_120_set_non_defaults.ml \
 	test_130_private_data.ml \
@@ -49,6 +50,7 @@ if HAVE_NBDKIT
 tests_bc = \
 	test_010_import.bc \
 	test_100_handle.bc \
+	test_105_with_handle.bc \
 	test_110_defaults.bc \
 	test_120_set_non_defaults.bc \
 	test_130_private_data.bc \
@@ -73,6 +75,7 @@ tests_bc = \
 tests_opt = \
 	test_010_import.opt \
 	test_100_handle.opt \
+	test_105_with_handle.opt \
 	test_110_defaults.opt \
 	test_120_set_non_defaults.opt \
 	test_130_private_data.opt \
diff --git a/ocaml/tests/test_105_with_handle.ml
b/ocaml/tests/test_105_with_handle.ml
new file mode 100644
index 000000000..6957c0a71
--- /dev/null
+++ b/ocaml/tests/test_105_with_handle.ml
@@ -0,0 +1,37 @@
+(* hey emacs, this is OCaml code: -*- tuareg -*- *)
+(* libnbd OCaml test case
+ * Copyright (C) 2013-2021 Red Hat Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+
+exception Test
+
+let () +  NBD.with_handle (fun nbd -> ());
+
+  (try
+     ignore (NBD.with_handle (fun nbd -> raise Test));
+     assert false
+   with Test -> () (* expected *)
+      | exn -> failwith (Printexc.to_string exn)
+  );
+
+  (* Were two handles created above?
+   * XXX How to test if close was called twice?
+   *)
+  assert (NBD.get_handle_name (NBD.create ()) = "nbd3")
+
+let () = Gc.compact ()
diff --git a/ocaml/tests/test_110_defaults.ml b/ocaml/tests/test_110_defaults.ml
index f5886fca3..b36949f0b 100644
--- a/ocaml/tests/test_110_defaults.ml
+++ b/ocaml/tests/test_110_defaults.ml
@@ -18,18 +18,20 @@
  *)

 let () -  let nbd = NBD.create () in
-  let name = NBD.get_export_name nbd in
-  assert (name = "");
-  let info = NBD.get_full_info nbd in
-  assert (info = false);
-  let tls = NBD.get_tls nbd in
-  assert (tls = NBD.TLS.DISABLE);
-  let sr = NBD.get_request_structured_replies nbd in
-  assert (sr = true);
-  let flags = NBD.get_handshake_flags nbd in
-  assert (flags = NBD.HANDSHAKE_FLAG.mask);
-  let opt = NBD.get_opt_mode nbd in
-  assert (opt = false)
+  NBD.with_handle (
+    fun nbd ->
+      let name = NBD.get_export_name nbd in
+      assert (name = "");
+      let info = NBD.get_full_info nbd in
+      assert (info = false);
+      let tls = NBD.get_tls nbd in
+      assert (tls = NBD.TLS.DISABLE);
+      let sr = NBD.get_request_structured_replies nbd in
+      assert (sr = true);
+      let flags = NBD.get_handshake_flags nbd in
+      assert (flags = NBD.HANDSHAKE_FLAG.mask);
+      let opt = NBD.get_opt_mode nbd in
+      assert (opt = false)
+  )

 let () = Gc.compact ()
diff --git a/ocaml/tests/test_120_set_non_defaults.ml
b/ocaml/tests/test_120_set_non_defaults.ml
index 421baaba4..67928bb58 100644
--- a/ocaml/tests/test_120_set_non_defaults.ml
+++ b/ocaml/tests/test_120_set_non_defaults.ml
@@ -18,42 +18,44 @@
  *)

 let () -  let nbd = NBD.create () in
-  NBD.set_export_name nbd "name";
-  let name = NBD.get_export_name nbd in
-  assert (name = "name");
-  NBD.set_full_info nbd true;
-  let info = NBD.get_full_info nbd in
-  assert (info = true);
-  (try
-     NBD.set_tls nbd (NBD.TLS.UNKNOWN 3);
-     assert (false)
-   with
-     NBD.Error _ -> ()
-  );
-  let tls = NBD.get_tls nbd in
-  assert (tls = NBD.TLS.DISABLE);
-  if NBD.supports_tls nbd then (
-    NBD.set_tls nbd NBD.TLS.ALLOW;
-    let tls = NBD.get_tls nbd in
-    assert (tls = NBD.TLS.ALLOW);
-  );
-  NBD.set_request_structured_replies nbd false;
-  let sr = NBD.get_request_structured_replies nbd in
-  assert (sr = false);
-  (try
-     NBD.set_handshake_flags nbd [ NBD.HANDSHAKE_FLAG.UNKNOWN 2 ];
-     assert false
-   with
-     NBD.Error _ -> ()
-  );
-  let flags = NBD.get_handshake_flags nbd in
-  assert (flags = NBD.HANDSHAKE_FLAG.mask);
-  NBD.set_handshake_flags nbd [];
-  let flags = NBD.get_handshake_flags nbd in
-  assert (flags = []);
-  NBD.set_opt_mode nbd true;
-  let opt = NBD.get_opt_mode nbd in
-  assert (opt = true)
+  NBD.with_handle (
+    fun nbd ->
+      NBD.set_export_name nbd "name";
+      let name = NBD.get_export_name nbd in
+      assert (name = "name");
+      NBD.set_full_info nbd true;
+      let info = NBD.get_full_info nbd in
+      assert (info = true);
+      (try
+         NBD.set_tls nbd (NBD.TLS.UNKNOWN 3);
+         assert (false)
+       with
+         NBD.Error _ -> ()
+      );
+      let tls = NBD.get_tls nbd in
+      assert (tls = NBD.TLS.DISABLE);
+      if NBD.supports_tls nbd then (
+        NBD.set_tls nbd NBD.TLS.ALLOW;
+        let tls = NBD.get_tls nbd in
+        assert (tls = NBD.TLS.ALLOW);
+      );
+      NBD.set_request_structured_replies nbd false;
+      let sr = NBD.get_request_structured_replies nbd in
+      assert (sr = false);
+      (try
+         NBD.set_handshake_flags nbd [ NBD.HANDSHAKE_FLAG.UNKNOWN 2 ];
+         assert false
+       with
+         NBD.Error _ -> ()
+      );
+      let flags = NBD.get_handshake_flags nbd in
+      assert (flags = NBD.HANDSHAKE_FLAG.mask);
+      NBD.set_handshake_flags nbd [];
+      let flags = NBD.get_handshake_flags nbd in
+      assert (flags = []);
+      NBD.set_opt_mode nbd true;
+      let opt = NBD.get_opt_mode nbd in
+      assert (opt = true)
+  )

 let () = Gc.compact ()
diff --git a/ocaml/tests/test_200_connect_command.ml
b/ocaml/tests/test_200_connect_command.ml
index dd64b09f4..17d1b50ef 100644
--- a/ocaml/tests/test_200_connect_command.ml
+++ b/ocaml/tests/test_200_connect_command.ml
@@ -18,8 +18,11 @@
  *)

 let () -  let nbd = NBD.create () in
-  NBD.connect_command nbd
-                      ["nbdkit"; "-s";
"--exit-with-parent"; "-v"; "null"]
+  NBD.with_handle (
+    fun nbd ->
+      NBD.connect_command nbd
+                          ["nbdkit"; "-s";
"--exit-with-parent"; "-v";
+                           "null"]
+  )

 let () = Gc.compact ()
diff --git a/ocaml/tests/test_400_pread.ml b/ocaml/tests/test_400_pread.ml
index b798633f0..e6b550ac9 100644
--- a/ocaml/tests/test_400_pread.ml
+++ b/ocaml/tests/test_400_pread.ml
@@ -37,12 +37,16 @@ let expected    b

 let () -  let nbd = NBD.create () in
-  NBD.connect_command nbd
-                      ["nbdkit"; "-s";
"--exit-with-parent"; "-v";
-                       "pattern"; "size=512"];
-  let buf = Bytes.create 512 in
-  NBD.pread nbd buf 0_L;
+  let buf +    NBD.with_handle (
+      fun nbd ->
+        NBD.connect_command nbd
+                            ["nbdkit"; "-s";
"--exit-with-parent"; "-v";
+                             "pattern"; "size=512"];
+        let buf = Bytes.create 512 in
+        NBD.pread nbd buf 0_L;
+        buf
+    ) in

   printf "buf = %S\n" (Bytes.to_string buf);
   printf "expected = %S\n" (Bytes.to_string expected);
--
2.32.0