Libguestfs - Feb 2020 - [nbdkit PATCH] ocaml: Support .preconnect callback

Somewhat of a mishmash between .open (in that it takes a bool readonly
parameter) and .config_complete (in that the C code returns an int,
but the Ocaml code either throws an exception or completes with unit).
I did not spot any existing testsuite coverage to modify for this, and
am relying on the fact that it compiles cleanly.

Signed-off-by: Eric Blake <eblake@redhat.com>
---
 plugins/ocaml/NBDKit.ml  | 12 ++++++++++--
 plugins/ocaml/NBDKit.mli |  4 +++-
 plugins/ocaml/ocaml.c    | 27 ++++++++++++++++++++++++++-
 3 files changed, 39 insertions(+), 4 deletions(-)

diff --git a/plugins/ocaml/NBDKit.ml b/plugins/ocaml/NBDKit.ml
index 7002ac0..85c30a1 100644
--- a/plugins/ocaml/NBDKit.ml
+++ b/plugins/ocaml/NBDKit.ml
@@ -1,6 +1,6 @@
 (* hey emacs, this is OCaml code: -*- tuareg -*- *)
 (* nbdkit OCaml interface
- * Copyright (C) 2014-2019 Red Hat Inc.
+ * Copyright (C) 2014-2020 Red Hat Inc.
  *
  * Redistribution and use in source and binary forms, with or without
  * modification, are permitted provided that the following conditions are
@@ -98,6 +98,8 @@ type 'a plugin = {
   thread_model : (unit -> thread_model) option;

   can_fast_zero : ('a -> bool) option;
+
+  preconnect : (bool -> unit) option;
 }

 let default_callbacks = {
@@ -145,6 +147,8 @@ let default_callbacks = {
   thread_model = None;

   can_fast_zero = None;
+
+  preconnect = None;
 }

 external set_name : string -> unit = "ocaml_nbdkit_set_name"
"noalloc"
@@ -192,6 +196,8 @@ external set_thread_model : (unit -> thread_model) ->
unit = "ocaml_nbdkit_set_t

 external set_can_fast_zero : ('a -> bool) -> unit =
"ocaml_nbdkit_set_can_fast_zero"

+external set_preconnect : (bool -> unit) -> unit =
"ocaml_nbdkit_set_preconnect"
+
 let may f = function None -> () | Some a -> f a

 let register_plugin plugin @@ -257,7 +263,9 @@ let register_plugin plugin 
   may set_thread_model plugin.thread_model;

-  may set_can_fast_zero plugin.can_fast_zero
+  may set_can_fast_zero plugin.can_fast_zero;
+
+  may set_preconnect plugin.preconnect

 external _set_error : int -> unit = "ocaml_nbdkit_set_error"
"noalloc"

diff --git a/plugins/ocaml/NBDKit.mli b/plugins/ocaml/NBDKit.mli
index 06648b7..4cdf911 100644
--- a/plugins/ocaml/NBDKit.mli
+++ b/plugins/ocaml/NBDKit.mli
@@ -1,6 +1,6 @@
 (* hey emacs, this is OCaml code: -*- tuareg -*- *)
 (* nbdkit OCaml interface
- * Copyright (C) 2014-2019 Red Hat Inc.
+ * Copyright (C) 2014-2020 Red Hat Inc.
  *
  * Redistribution and use in source and binary forms, with or without
  * modification, are permitted provided that the following conditions are
@@ -103,6 +103,8 @@ type 'a plugin = {
   thread_model : (unit -> thread_model) option;

   can_fast_zero : ('a -> bool) option;
+
+  preconnect : (bool -> unit) option;
 }
 (** The plugin fields and callbacks.  ['a] is the handle type. *)

diff --git a/plugins/ocaml/ocaml.c b/plugins/ocaml/ocaml.c
index cb69290..a7d188f 100644
--- a/plugins/ocaml/ocaml.c
+++ b/plugins/ocaml/ocaml.c
@@ -1,5 +1,5 @@
 /* nbdkit
- * Copyright (C) 2014-2019 Red Hat Inc.
+ * Copyright (C) 2014-2020 Red Hat Inc.
  *
  * Redistribution and use in source and binary forms, with or without
  * modification, are permitted provided that the following conditions are
@@ -136,6 +136,8 @@ static value thread_model_fn;

 static value can_fast_zero_fn;

+static value preconnect_fn;
+
 /*----------------------------------------------------------------------*/
 /* Wrapper functions that translate calls from C (ie. nbdkit) to OCaml. */

@@ -726,6 +728,25 @@ can_fast_zero_wrapper (void *h)
   CAMLreturnT (int, Bool_val (rv));
 }

+static int
+preconnect_wrapper (int readonly)
+{
+  CAMLparam0 ();
+  CAMLlocal1 (rv);
+
+  caml_leave_blocking_section ();
+
+  rv = caml_callback_exn (preconnect_fn, Val_bool (readonly));
+  if (Is_exception_result (rv)) {
+    nbdkit_error ("%s", caml_format_exception (Extract_exception
(rv)));
+    caml_enter_blocking_section ();
+    CAMLreturnT (int, -1);
+  }
+
+  caml_enter_blocking_section ();
+  CAMLreturnT (int, 1);
+}
+
 /*----------------------------------------------------------------------*/
 /* set_* functions called from OCaml code at load time to initialize
  * fields in the plugin struct.
@@ -815,6 +836,8 @@ SET(thread_model)

 SET(can_fast_zero)

+SET(preconnect)
+
 #undef SET

 static void
@@ -861,6 +884,8 @@ remove_roots (void)

   REMOVE (can_fast_zero);

+  REMOVE (preconnect);
+
 #undef REMOVE
 }

-- 
2.24.1

On Mon, Feb 10, 2020 at 12:47:47PM -0600, Eric Blake
wrote:
> Somewhat of a mishmash between .open (in that it takes a bool readonly
> parameter) and .config_complete (in that the C code returns an int,
> but the Ocaml code either throws an exception or completes with unit).
> I did not spot any existing testsuite coverage to modify for this, and
> am relying on the fact that it compiles cleanly.
> 
> Signed-off-by: Eric Blake <eblake@redhat.com>
> ---
>  plugins/ocaml/NBDKit.ml  | 12 ++++++++++--
>  plugins/ocaml/NBDKit.mli |  4 +++-
>  plugins/ocaml/ocaml.c    | 27 ++++++++++++++++++++++++++-
>  3 files changed, 39 insertions(+), 4 deletions(-)
> 
> diff --git a/plugins/ocaml/NBDKit.ml b/plugins/ocaml/NBDKit.ml
> index 7002ac0..85c30a1 100644
> --- a/plugins/ocaml/NBDKit.ml
> +++ b/plugins/ocaml/NBDKit.ml
> @@ -1,6 +1,6 @@
>  (* hey emacs, this is OCaml code: -*- tuareg -*- *)
>  (* nbdkit OCaml interface
> - * Copyright (C) 2014-2019 Red Hat Inc.
> + * Copyright (C) 2014-2020 Red Hat Inc.
>   *
>   * Redistribution and use in source and binary forms, with or without
>   * modification, are permitted provided that the following conditions are
> @@ -98,6 +98,8 @@ type 'a plugin = {
>    thread_model : (unit -> thread_model) option;
> 
>    can_fast_zero : ('a -> bool) option;
> +
> +  preconnect : (bool -> unit) option;
>  }
> 
>  let default_callbacks = {
> @@ -145,6 +147,8 @@ let default_callbacks = {
>    thread_model = None;
> 
>    can_fast_zero = None;
> +
> +  preconnect = None;
>  }
> 
>  external set_name : string -> unit = "ocaml_nbdkit_set_name"
"noalloc"
> @@ -192,6 +196,8 @@ external set_thread_model : (unit -> thread_model)
-> unit = "ocaml_nbdkit_set_t
> 
>  external set_can_fast_zero : ('a -> bool) -> unit =
"ocaml_nbdkit_set_can_fast_zero"
> 
> +external set_preconnect : (bool -> unit) -> unit =
"ocaml_nbdkit_set_preconnect"
> +
>  let may f = function None -> () | Some a -> f a
> 
>  let register_plugin plugin > @@ -257,7 +263,9 @@ let register_plugin
plugin >
>    may set_thread_model plugin.thread_model;
> 
> -  may set_can_fast_zero plugin.can_fast_zero
> +  may set_can_fast_zero plugin.can_fast_zero;
> +
> +  may set_preconnect plugin.preconnect
> 
>  external _set_error : int -> unit = "ocaml_nbdkit_set_error"
"noalloc"
> 
> diff --git a/plugins/ocaml/NBDKit.mli b/plugins/ocaml/NBDKit.mli
> index 06648b7..4cdf911 100644
> --- a/plugins/ocaml/NBDKit.mli
> +++ b/plugins/ocaml/NBDKit.mli
> @@ -1,6 +1,6 @@
>  (* hey emacs, this is OCaml code: -*- tuareg -*- *)
>  (* nbdkit OCaml interface
> - * Copyright (C) 2014-2019 Red Hat Inc.
> + * Copyright (C) 2014-2020 Red Hat Inc.
>   *
>   * Redistribution and use in source and binary forms, with or without
>   * modification, are permitted provided that the following conditions are
> @@ -103,6 +103,8 @@ type 'a plugin = {
>    thread_model : (unit -> thread_model) option;
> 
>    can_fast_zero : ('a -> bool) option;
> +
> +  preconnect : (bool -> unit) option;
>  }
>  (** The plugin fields and callbacks.  ['a] is the handle type. *)
> 
> diff --git a/plugins/ocaml/ocaml.c b/plugins/ocaml/ocaml.c
> index cb69290..a7d188f 100644
> --- a/plugins/ocaml/ocaml.c
> +++ b/plugins/ocaml/ocaml.c
> @@ -1,5 +1,5 @@
>  /* nbdkit
> - * Copyright (C) 2014-2019 Red Hat Inc.
> + * Copyright (C) 2014-2020 Red Hat Inc.
>   *
>   * Redistribution and use in source and binary forms, with or without
>   * modification, are permitted provided that the following conditions are
> @@ -136,6 +136,8 @@ static value thread_model_fn;
> 
>  static value can_fast_zero_fn;
> 
> +static value preconnect_fn;
> +
>  /*----------------------------------------------------------------------*/
>  /* Wrapper functions that translate calls from C (ie. nbdkit) to OCaml. */
> 
> @@ -726,6 +728,25 @@ can_fast_zero_wrapper (void *h)
>    CAMLreturnT (int, Bool_val (rv));
>  }
> 
> +static int
> +preconnect_wrapper (int readonly)
> +{
> +  CAMLparam0 ();
> +  CAMLlocal1 (rv);
> +
> +  caml_leave_blocking_section ();
> +
> +  rv = caml_callback_exn (preconnect_fn, Val_bool (readonly));
> +  if (Is_exception_result (rv)) {
> +    nbdkit_error ("%s", caml_format_exception (Extract_exception
(rv)));
> +    caml_enter_blocking_section ();
> +    CAMLreturnT (int, -1);
> +  }
> +
> +  caml_enter_blocking_section ();
> +  CAMLreturnT (int, 1);
> +}
> +
>  /*----------------------------------------------------------------------*/
>  /* set_* functions called from OCaml code at load time to initialize
>   * fields in the plugin struct.
> @@ -815,6 +836,8 @@ SET(thread_model)
> 
>  SET(can_fast_zero)
> 
> +SET(preconnect)
> +
>  #undef SET
> 
>  static void
> @@ -861,6 +884,8 @@ remove_roots (void)
> 
>    REMOVE (can_fast_zero);
> 
> +  REMOVE (preconnect);
> +
>  #undef REMOVE
>  }
> 
Looks fine, ACK.

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
libguestfs lets you edit virtual machines.  Supports shell scripting,
bindings from many languages.  http://libguestfs.org