From 011a75749213a347443ad3e5ee5fc04481f8433a Mon Sep 17 00:00:00 2001 From: Richard Jones 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. For stable-1.2 branch: - cherry picked from commit 1079f74704a06c06996e547fdecf20a8f92799c6 - generator code rebased --- .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 | 21 +++++++----- 6 files changed, 103 insertions(+), 19 deletions(-) create mode 100644 ocaml/t/guestfs_070_threads.ml diff --git a/.gitignore b/.gitignore index c860cbd..5ed1d84 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..71f416a 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] = guestfs_safe_strdup (g, 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 f32e064..87b36df 100755 --- a/src/generator.ml +++ b/src/generator.ml @@ -5954,6 +5954,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) @@ -7919,7 +7921,7 @@ and generate_ocaml_c () = #include #include -#include +#include \"guestfs.h\" #include \"guestfs_c.h\" @@ -8087,11 +8089,12 @@ 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 | StringList n | DeviceList n -> pr " char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n | Bool n -> @@ -8134,13 +8137,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 -> + 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 _ -> () + | Bool _ | Int _ | Int64 _ -> () ) (snd style); pr " if (r == %s)\n" error_code; -- 1.8.3.1