Fixes for https://github.com/ocaml/ocaml/issues/12820

0001-ocaml-Use-Gc.finalise-instead-of-a-C-finalizer.patch

@@ -0,0 +1,134 @@
+From 61418535ad63b5a2a91f1caf4703d7134834e4dd Mon Sep 17 00:00:00 2001
+From: "Richard W.M. Jones" <rjones@redhat.com>
+Date: Wed, 13 Dec 2023 22:50:56 +0000
+Subject: [PATCH 1/2] ocaml: Use Gc.finalise instead of a C finalizer
+
+Since OCaml 5.1.1, changes to custom blocks caused C finalizers that
+call caml_enter_blocking_section to stop working (if they ever did
+before).  They are relatively inflexible compared to registering an
+OCaml finalizer (Gc.finalise) to call Guestfs.close, so use that
+instead.
+
+Suggested-by: Guillaume Munch-Maccagnoni
+See: https://github.com/ocaml/ocaml/issues/12820
+See: https://gitlab.com/nbdkit/libnbd/-/commit/db48794fa89547a4799b832331e82b4b8b98f03d
+---
+ generator/OCaml.ml |  7 ++++-
+ ocaml/guestfs-c.c  | 69 +++++++++++++++++++++-------------------------
+ 2 files changed, 37 insertions(+), 39 deletions(-)
+
+diff --git a/generator/OCaml.ml b/generator/OCaml.ml
+index 07ccd26924..1e6f603ab2 100644
+--- a/generator/OCaml.ml
++++ b/generator/OCaml.ml
+@@ -312,10 +312,15 @@ type t
+ exception Error of string
+ exception Handle_closed of string
+ 
+-external create : ?environment:bool -> ?close_on_exit:bool -> unit -> t =
++external _create : ?environment:bool -> ?close_on_exit:bool -> unit -> t =
+   \"guestfs_int_ocaml_create\"
+ external close : t -> unit = \"guestfs_int_ocaml_close\"
+ 
++let create ?environment ?close_on_exit () =
++  let g = _create ?environment ?close_on_exit () in
++  Gc.finalise close g;
++  g
++
+ type event =
+ ";
+   List.iter (
+diff --git a/ocaml/guestfs-c.c b/ocaml/guestfs-c.c
+index 8a8761e883..700c33abf4 100644
+--- a/ocaml/guestfs-c.c
++++ b/ocaml/guestfs-c.c
+@@ -61,43 +61,10 @@ value guestfs_int_ocaml_delete_event_callback (value gv, value eh);
+ value guestfs_int_ocaml_event_to_string (value events);
+ value guestfs_int_ocaml_last_errno (value gv);
+ 
+-/* Allocate handles and deal with finalization. */
+-static void
+-guestfs_finalize (value gv)
+-{
+-  guestfs_h *g = Guestfs_val (gv);
+-
+-  if (g) {
+-    /* There is a nasty, difficult to solve case here where the
+-     * user deletes events in one of the callbacks that we are
+-     * about to invoke, resulting in a double-free.  XXX
+-     */
+-    size_t len;
+-    value **roots = get_all_event_callbacks (g, &len);
+-
+-    /* Close the handle: this could invoke callbacks from the list
+-     * above, which is why we don't want to delete them before
+-     * closing the handle.
+-     */
+-    caml_release_runtime_system ();
+-    guestfs_close (g);
+-    caml_acquire_runtime_system ();
+-
+-    /* Now unregister the global roots. */
+-    if (roots && len > 0) {
+-      size_t i;
+-      for (i = 0; i < len; ++i) {
+-        caml_remove_generational_global_root (roots[i]);
+-        free (roots[i]);
+-      }
+-      free (roots);
+-    }
+-  }
+-}
+-
++/* Allocate handles. */
+ static struct custom_operations guestfs_custom_operations = {
+   (char *) "guestfs_custom_operations",
+-  guestfs_finalize,
++  custom_finalize_default,
+   custom_compare_default,
+   custom_hash_default,
+   custom_serialize_default,
+@@ -179,11 +146,37 @@ value
+ guestfs_int_ocaml_close (value gv)
+ {
+   CAMLparam1 (gv);
++  guestfs_h *g = Guestfs_val (gv);
+ 
+-  guestfs_finalize (gv);
++  if (g) {
++    /* There is a nasty, difficult to solve case here where the
++     * user deletes events in one of the callbacks that we are
++     * about to invoke, resulting in a double-free.  XXX
++     */
++    size_t len;
++    value **roots = get_all_event_callbacks (g, &len);
+ 
+-  /* So we don't double-free in the finalizer. */
+-  Guestfs_val (gv) = NULL;
++    /* Close the handle: this could invoke callbacks from the list
++     * above, which is why we don't want to delete them before
++     * closing the handle.
++     */
++    caml_release_runtime_system ();
++    guestfs_close (g);
++    caml_acquire_runtime_system ();
++
++    /* Now unregister the global roots. */
++    if (roots && len > 0) {
++      size_t i;
++      for (i = 0; i < len; ++i) {
++        caml_remove_generational_global_root (roots[i]);
++        free (roots[i]);
++      }
++      free (roots);
++    }
++
++    /* So we don't double-free. */
++    Guestfs_val (gv) = NULL;
++  }
+ 
+   CAMLreturn (Val_unit);
+ }
+-- 
+2.43.0
+

0002-ocaml-Nullify-custom-block-before-releasing-runtime-.patch

@@ -0,0 +1,41 @@
+From e93fd7e8acf34192c0d1b70611e3474dde346941 Mon Sep 17 00:00:00 2001
+From: "Richard W.M. Jones" <rjones@redhat.com>
+Date: Thu, 14 Dec 2023 08:33:10 +0000
+Subject: [PATCH 2/2] ocaml: Nullify custom block before releasing runtime lock
+
+Avoids a potential, though if possible then very rare, double free
+path.
+
+Suggested-by: Guillaume Munch-Maccagnoni
+See: https://github.com/ocaml/ocaml/issues/12820
+---
+ ocaml/guestfs-c.c | 6 +++---
+ 1 file changed, 3 insertions(+), 3 deletions(-)
+
+diff --git a/ocaml/guestfs-c.c b/ocaml/guestfs-c.c
+index 700c33abf4..ea9a0598a6 100644
+--- a/ocaml/guestfs-c.c
++++ b/ocaml/guestfs-c.c
+@@ -156,6 +156,9 @@ guestfs_int_ocaml_close (value gv)
+     size_t len;
+     value **roots = get_all_event_callbacks (g, &len);
+ 
++    /* So we don't double-free. */
++    Guestfs_val (gv) = NULL;
++
+     /* Close the handle: this could invoke callbacks from the list
+      * above, which is why we don't want to delete them before
+      * closing the handle.
+@@ -173,9 +176,6 @@ guestfs_int_ocaml_close (value gv)
+       }
+       free (roots);
+     }
+-
+-    /* So we don't double-free. */
+-    Guestfs_val (gv) = NULL;
+   }
+ 
+   CAMLreturn (Val_unit);
+-- 
+2.43.0
+

libguestfs.spec

@@ -50,7 +50,7 @@ Summary:       Access and modify virtual machine disk images
 Name:          libguestfs
 Epoch:         1
 Version:       1.51.9
-Release:       2%{?dist}
+Release:       3%{?dist}
 License:       LGPL-2.1-or-later
 
 # Build only for architectures that have a kernel
@@ -84,6 +84,10 @@ Source7:       libguestfs.keyring
 # Maintainer script which helps with handling patches.
 Source8:       copy-patches.sh
 
+# Fixes for https://github.com/ocaml/ocaml/issues/12820
+Patch: 0001-ocaml-Use-Gc.finalise-instead-of-a-C-finalizer.patch
+Patch: 0002-ocaml-Nullify-custom-block-before-releasing-runtime-.patch
+
 %if 0%{patches_touch_autotools}
 BuildRequires: autoconf, automake, libtool, gettext-devel
 %endif
@@ -1094,6 +1098,9 @@ rm ocaml/html/.gitignore
 
 
 %changelog
+* Thu Dec 14 2023 Richard W.M. Jones <rjones@redhat.com> - 1:1.51.9-3
+- Fixes for https://github.com/ocaml/ocaml/issues/12820
+
 * Tue Dec 12 2023 Richard W.M. Jones <rjones@redhat.com> - 1:1.51.9-2
 - OCaml 5.1.1 rebuild for Fedora 40