[Libguestfs] [PATCH] ocaml: Fix thread safety of strings in bindings (RHBZ#604691).
Richard W.M. Jones
rjones at redhat.com
Wed Jun 16 14:28:39 UTC 2010
--
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
virt-top is 'top' for virtual machines. Tiny program with many
powerful monitoring features, net stats, disk stats, logging, etc.
http://et.redhat.com/~rjones/virt-top
-------------- next part --------------
>From 20d557ef71df326280877f76777ab485be981d12 Mon Sep 17 00:00:00 2001
From: Richard Jones <rjones at redhat.com>
Date: Wed, 16 Jun 2010 15:25:45 +0100
Subject: [PATCH] ocaml: Fix thread safety of strings in bindings (RHBZ#604691).
There's a thread safety issue with the current OCaml bindings which
is well explained in the bug report:
https://bugzilla.redhat.com/show_bug.cgi?id=604691
This commit fixes the safety issue by copying strings temporarily
before releasing the thread lock. Updated code looks like this:
char *filename = guestfs_safe_strdup (g, String_val (filenamev));
int r;
caml_enter_blocking_section ();
r = guestfs_add_drive_ro (g, filename);
caml_leave_blocking_section ();
free (filename);
if (r == -1)
ocaml_guestfs_raise_error (g, "add_drive_ro");
Also included is a regression test.
---
.gitignore | 1 +
ocaml/Makefile.am | 11 +++++-
ocaml/guestfs_c.c | 15 +++-----
ocaml/guestfs_c.h | 2 +
ocaml/t/guestfs_070_threads.ml | 72 ++++++++++++++++++++++++++++++++++++++++
src/generator.ml | 25 ++++++++-----
6 files changed, 105 insertions(+), 21 deletions(-)
create mode 100644 ocaml/t/guestfs_070_threads.ml
diff --git a/.gitignore b/.gitignore
index 9997356..15b496a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -167,6 +167,7 @@ ocaml/t/guestfs_005_load
ocaml/t/guestfs_010_launch
ocaml/t/guestfs_050_lvcreate
ocaml/t/guestfs_060_readdir
+ocaml/t/guestfs_070_threads
ocaml/t/guestfs_500_inspect
perl/bindtests.pl
perl/blib
diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am
index 38238f6..99bb390 100644
--- a/ocaml/Makefile.am
+++ b/ocaml/Makefile.am
@@ -67,10 +67,10 @@ TESTS_ENVIRONMENT = \
TESTS = run-bindtests \
t/guestfs_005_load t/guestfs_010_launch t/guestfs_050_lvcreate \
- t/guestfs_060_readdir t/guestfs_500_inspect
+ t/guestfs_060_readdir t/guestfs_070_threads t/guestfs_500_inspect
noinst_DATA += bindtests \
t/guestfs_005_load t/guestfs_010_launch t/guestfs_050_lvcreate \
- t/guestfs_060_readdir t/guestfs_500_inspect
+ t/guestfs_060_readdir t/guestfs_070_threads t/guestfs_500_inspect
bindtests: bindtests.cmx mlguestfs.cmxa
mkdir -p t
@@ -92,12 +92,19 @@ t/guestfs_060_readdir: t/guestfs_060_readdir.cmx mlguestfs.cmxa
mkdir -p t
$(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package xml-light,unix -linkpkg mlguestfs.cmxa $< -o $@
+t/guestfs_070_threads: t/guestfs_070_threads.cmx mlguestfs.cmxa
+ mkdir -p t
+ $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package unix,threads -thread -linkpkg mlguestfs.cmxa $< -o $@
+
t/guestfs_500_inspect: t/guestfs_500_inspect.cmx mlguestfs.cmxa
mkdir -p t
$(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package xml-light,unix -linkpkg mlguestfs.cmxa $< -o $@
# Need to rebuild the tests from source if the main library has
# changed at all, otherwise we get inconsistent assumptions.
+t/guestfs_070_threads.cmx: t/guestfs_070_threads.ml mlguestfs.cmxa
+ $(OCAMLFIND) ocamlopt -package unix,threads -thread -linkpkg -c $< -o $@
+
t/%.cmx: t/%.ml mlguestfs.cmxa
$(OCAMLFIND) ocamlopt -package xml-light,unix -linkpkg -c $< -o $@
diff --git a/ocaml/guestfs_c.c b/ocaml/guestfs_c.c
index f7d8dff..6e51575 100644
--- a/ocaml/guestfs_c.c
+++ b/ocaml/guestfs_c.c
@@ -136,11 +136,7 @@ ocaml_guestfs_close (value gv)
CAMLreturn (Val_unit);
}
-/* Copy string array value.
- * The return value is only 'safe' provided we don't allocate anything
- * further on the OCaml heap (ie. cannot trigger the OCaml GC) because
- * that could move the strings around.
- */
+/* Copy string array value. */
char **
ocaml_guestfs_strings_val (guestfs_h *g, value sv)
{
@@ -150,7 +146,7 @@ ocaml_guestfs_strings_val (guestfs_h *g, value sv)
r = guestfs_safe_malloc (g, sizeof (char *) * (Wosize_val (sv) + 1));
for (i = 0; i < Wosize_val (sv); ++i)
- r[i] = String_val (Field (sv, i));
+ r[i] = strdup (String_val (Field (sv, i)));
r[i] = NULL;
CAMLreturnT (char **, r);
@@ -160,8 +156,9 @@ ocaml_guestfs_strings_val (guestfs_h *g, value sv)
void
ocaml_guestfs_free_strings (char **argv)
{
- /* Don't free the actual strings - they are String_vals on
- * the OCaml heap.
- */
+ unsigned int i;
+
+ for (i = 0; argv[i] != NULL; ++i)
+ free (argv[i]);
free (argv);
}
diff --git a/ocaml/guestfs_c.h b/ocaml/guestfs_c.h
index cd1d73b..29da053 100644
--- a/ocaml/guestfs_c.h
+++ b/ocaml/guestfs_c.h
@@ -19,6 +19,8 @@
#ifndef GUESTFS_OCAML_C_H
#define GUESTFS_OCAML_C_H
+#include "guestfs-internal.h"
+
#define Guestfs_val(v) (*((guestfs_h **)Data_custom_val(v)))
extern void ocaml_guestfs_raise_error (guestfs_h *g, const char *func)
Noreturn;
diff --git a/ocaml/t/guestfs_070_threads.ml b/ocaml/t/guestfs_070_threads.ml
new file mode 100644
index 0000000..e13ac7b
--- /dev/null
+++ b/ocaml/t/guestfs_070_threads.ml
@@ -0,0 +1,72 @@
+(* libguestfs OCaml bindings
+ * Copyright (C) 2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+open Unix
+
+(* Start a background thread which does lots of allocation and
+ * GC activity.
+ *)
+let thread = Thread.create (
+ fun () ->
+ while true do
+ Gc.compact ();
+ ignore (Array.init 1000 (fun i -> Thread.yield (); String.create (8*i)))
+ done
+) ()
+
+let () =
+ let g = Guestfs.create () in
+
+ let fd = openfile "test.img" [O_WRONLY;O_CREAT;O_NOCTTY;O_TRUNC] 0o666 in
+ ftruncate fd (500 * 1024 * 1024);
+ close fd;
+
+ (* Copy these strings so they're located on the heap and
+ * subject to garbage collection.
+ *)
+ let s = String.copy "test.img" in
+ Guestfs.add_drive_ro g s;
+ Guestfs.launch g;
+
+ let dev = String.copy "/dev/sda" in
+ Guestfs.pvcreate g dev;
+ let vg = String.copy "VG" in
+ Guestfs.vgcreate g vg [|dev|];
+ let s = String.copy "LV1" in
+ Guestfs.lvcreate g s vg 200;
+ let s = String.copy "LV2" in
+ Guestfs.lvcreate g s vg 200;
+
+ let lvs = Guestfs.lvs g in
+ if lvs <> [|"/dev/VG/LV1"; "/dev/VG/LV2"|] then
+ failwith "Guestfs.lvs returned incorrect result";
+
+ let s = String.copy "ext3" in
+ let lv = String.copy "/dev/VG/LV1" in
+ Guestfs.mkfs g s lv;
+ let s = String.copy "/" in
+ Guestfs.mount_options g "" lv s;
+ let s = String.copy "/test" in
+ Guestfs.touch g s;
+
+ Guestfs.umount_all g;
+ Guestfs.sync g;
+ Guestfs.close g;
+ unlink "test.img";
+ Gc.compact ();
+ exit 0
diff --git a/src/generator.ml b/src/generator.ml
index 571870d..d640343 100755
--- a/src/generator.ml
+++ b/src/generator.ml
@@ -6349,6 +6349,8 @@ and generate_linker_script () =
*)
"guestfs_safe_calloc";
"guestfs_safe_malloc";
+ "guestfs_safe_strdup";
+ "guestfs_safe_memdup";
] in
let functions =
List.map (fun (name, _, _, _, _, _, _) -> "guestfs_" ^ name)
@@ -8395,7 +8397,7 @@ and generate_ocaml_c () =
#include <caml/mlvalues.h>
#include <caml/signals.h>
-#include <guestfs.h>
+#include \"guestfs.h\"
#include \"guestfs_c.h\"
@@ -8563,14 +8565,15 @@ copy_table (char * const * argv)
| String n
| FileIn n
| FileOut n ->
- pr " const char *%s = String_val (%sv);\n" n n
+ (* Copy strings in case the GC moves them: RHBZ#604691 *)
+ pr " char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
| OptString n ->
- pr " const char *%s =\n" n;
- pr " %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
- n n
+ pr " char *%s =\n" n;
+ pr " %sv != Val_int (0) ?" n;
+ pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
| BufferIn n ->
- pr " const char *%s = String_val (%sv);\n" n n;
- pr " size_t %s_size = caml_string_length (%sv);\n" n n
+ pr " size_t %s_size = caml_string_length (%sv);\n" n n;
+ pr " char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
| StringList n | DeviceList n ->
pr " char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
| Bool n ->
@@ -8613,13 +8616,15 @@ copy_table (char * const * argv)
pr ";\n";
pr " caml_leave_blocking_section ();\n";
+ (* Free strings if we copied them above. *)
List.iter (
function
+ | Pathname n | Device n | Dev_or_Path n | String n | OptString n
+ | FileIn n | FileOut n | BufferIn n ->
+ pr " free (%s);\n" n
| StringList n | DeviceList n ->
pr " ocaml_guestfs_free_strings (%s);\n" n;
- | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
- | Bool _ | Int _ | Int64 _
- | FileIn _ | FileOut _ | BufferIn _ -> ()
+ | Bool _ | Int _ | Int64 _ -> ()
) (snd style);
pr " if (r == %s)\n" error_code;
--
1.6.6.1
More information about the Libguestfs
mailing list