[PATCH] tools/ocaml/xenctrl: OCaml 5 support, fix use-after-free

[Andrew Cooper <andrew.cooper3@xxxxxxxxxx>]

The binding for xc_interface_close() free the underlying handle while leaving
the Ocaml object still in scope and usable.  This would make it easy to suffer
a use-after-free, if it weren't for the fact that the typical usage is as a
singleton that lives for the lifetime of the program.

Ocaml 5 no longer permits storing a naked C pointer in an Ocaml value.

Therefore, use a Custom block.  This allows us to use the finaliser callback
to call xc_interface_close(), if the Ocaml object goes out of scope.

Signed-off-by: Andrew Cooper <andrew.cooper3@xxxxxxxxxx>
---
CC: Christian Lindig <christian.lindig@xxxxxxxxxx>
CC: David Scott <dave@xxxxxxxxxx>
CC: Edwin Torok <edvin.torok@xxxxxxxxxx>
CC: Rob Hoes <Rob.Hoes@xxxxxxxxxx>

I've confirmed that Xenctrl.close_handle does cause the finaliser to be
called, simply by dropping the handle reference.
---
 tools/ocaml/libs/xc/xenctrl.ml      |  3 +--
 tools/ocaml/libs/xc/xenctrl.mli     |  1 -
 tools/ocaml/libs/xc/xenctrl_stubs.c | 43 ++++++++++++++++++++++---------------
 3 files changed, 27 insertions(+), 20 deletions(-)

diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml
index aa650533f718..4b74e31c75cb 100644
--- a/tools/ocaml/libs/xc/xenctrl.ml
+++ b/tools/ocaml/libs/xc/xenctrl.ml
@@ -175,7 +175,6 @@ exception Error of string
 type handle
 
 external interface_open: unit -> handle = "stub_xc_interface_open"
-external interface_close: handle -> unit = "stub_xc_interface_close"
 
 let handle = ref None
 
@@ -183,7 +182,7 @@ let get_handle () = !handle
 
 let close_handle () =
        match !handle with
-       | Some h -> handle := None; interface_close h
+       | Some h -> handle := None
        | None -> ()
 
 let with_intf f =
diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli
index 5bf5f5dfea36..ddfe84dc22a9 100644
--- a/tools/ocaml/libs/xc/xenctrl.mli
+++ b/tools/ocaml/libs/xc/xenctrl.mli
@@ -146,7 +146,6 @@ type shutdown_reason = Poweroff | Reboot | Suspend | Crash 
| Watchdog | Soft_res
 exception Error of string
 type handle
 external interface_open : unit -> handle = "stub_xc_interface_open"
-external interface_close : handle -> unit = "stub_xc_interface_close"
 
 (** [with_intf f] runs [f] with a global handle that is opened on demand
  * and kept open. Conceptually, a client should use either
diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c 
b/tools/ocaml/libs/xc/xenctrl_stubs.c
index f37848ae0bb3..4e1204085422 100644
--- a/tools/ocaml/libs/xc/xenctrl_stubs.c
+++ b/tools/ocaml/libs/xc/xenctrl_stubs.c
@@ -37,13 +37,28 @@
 
 #include "mmap_stubs.h"
 
-#define _H(__h) ((xc_interface *)(__h))
+#define _H(__h) (*((xc_interface **)Data_custom_val(__h)))
 #define _D(__d) ((uint32_t)Int_val(__d))
 
 #ifndef Val_none
 #define Val_none (Val_int(0))
 #endif
 
+static void stub_xenctrl_finalize(value v)
+{
+       xc_interface_close(_H(v));
+}
+
+static struct custom_operations xenctrl_ops = {
+       .identifier  = "xenctrl",
+       .finalize    = stub_xenctrl_finalize,
+       .compare     = custom_compare_default,     /* Can't compare     */
+       .hash        = custom_hash_default,        /* Can't hash        */
+       .serialize   = custom_serialize_default,   /* Can't serialize   */
+       .deserialize = custom_deserialize_default, /* Can't deserialize */
+       .compare_ext = custom_compare_ext_default, /* Can't compare     */
+};
+
 #define string_of_option_array(array, index) \
        ((Field(array, index) == Val_none) ? NULL : 
String_val(Field(Field(array, index), 0)))
 
@@ -70,26 +85,20 @@ static void Noreturn failwith_xc(xc_interface *xch)
 CAMLprim value stub_xc_interface_open(void)
 {
        CAMLparam0();
-        xc_interface *xch;
-
-       /* Don't assert XC_OPENFLAG_NON_REENTRANT because these bindings
-        * do not prevent re-entrancy to libxc */
-        xch = xc_interface_open(NULL, NULL, 0);
-        if (xch == NULL)
-               failwith_xc(NULL);
-        CAMLreturn((value)xch);
-}
-
-
-CAMLprim value stub_xc_interface_close(value xch)
-{
-       CAMLparam1(xch);
+       CAMLlocal1(result);
+       xc_interface *xch;
 
        caml_enter_blocking_section();
-       xc_interface_close(_H(xch));
+       xch = xc_interface_open(NULL, NULL, 0);
        caml_leave_blocking_section();
 
-       CAMLreturn(Val_unit);
+       if ( !xch )
+               failwith_xc(xch);
+
+       result = caml_alloc_custom(&xenctrl_ops, sizeof(xch), 0, 1);
+       _H(result) = xch;
+
+       CAMLreturn(result);
 }
 
 static void domain_handle_of_uuid_string(xen_domain_handle_t h,
-- 
2.11.0