diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | ocaml/Makefile.am | 25 | ||||
| -rw-r--r-- | ocaml/t/exit.c | 44 | ||||
| -rw-r--r-- | ocaml/t/guestfs_500_parallel_mount_local.ml | 197 | ||||
| -rw-r--r-- | po/POTFILES.in | 1 |
5 files changed, 267 insertions, 2 deletions
@@ -236,6 +236,8 @@ ocaml/t/guestfs_400_events.bc ocaml/t/guestfs_400_events.opt ocaml/t/guestfs_400_progress.bc ocaml/t/guestfs_400_progress.opt +ocaml/t/guestfs_500_parallel_mount_local.bc +ocaml/t/guestfs_500_parallel_mount_local.opt *.orig *.patch perl/bindtests.pl diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am index c3135329..8c742a22 100644 --- a/ocaml/Makefile.am +++ b/ocaml/Makefile.am @@ -30,6 +30,7 @@ EXTRA_DIST = \ html/.gitignore \ META.in \ run-bindtests \ + t/exit.c \ t/*.ml CLEANFILES = *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so @@ -87,7 +88,8 @@ if ENABLE_APPLIANCE test_progs += \ t/guestfs_010_basic \ t/guestfs_070_threads \ - t/guestfs_400_progress + t/guestfs_400_progress \ + t/guestfs_500_parallel_mount_local endif TESTS = run-bindtests \ @@ -163,13 +165,32 @@ t/guestfs_400_progress.opt: t/guestfs_400_progress.cmx mlguestfs.cmxa mkdir -p t $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -cclib -L$(top_builddir)/src/.libs -I . -package unix -linkpkg mlguestfs.cmxa $< -o $@ -# Explicit rules for this test which requires 'threads' package. +t/guestfs_500_parallel_mount_local.bc: t/guestfs_500_parallel_mount_local.cmo mlguestfs.cma libocamltestlib.a + mkdir -p t + LD_LIBRARY_PATH=../src/.libs \ + $(OCAMLFIND) ocamlc -custom $(OCAMLCFLAGS) -I . -package unix,threads -thread -linkpkg mlguestfs.cma libocamltestlib.a $< -o $@ + +t/guestfs_500_parallel_mount_local.opt: t/guestfs_500_parallel_mount_local.cmx mlguestfs.cmxa libocamltestlib.a + mkdir -p t + $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -cclib -L$(top_builddir)/src/.libs -I . -package unix,threads -thread -linkpkg mlguestfs.cmxa libocamltestlib.a $< -o $@ + +# Explicit rules for these tests which require 'threads' package. t/guestfs_070_threads.cmo: t/guestfs_070_threads.ml mlguestfs.cma $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -package unix,threads -thread -linkpkg -c $< -o $@ t/guestfs_070_threads.cmx: t/guestfs_070_threads.ml mlguestfs.cmxa $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -package unix,threads -thread -linkpkg -c $< -o $@ +t/guestfs_500_parallel_mount_local.cmo: t/guestfs_500_parallel_mount_local.ml mlguestfs.cma + $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -package unix,threads -thread -linkpkg -c $< -o $@ + +t/guestfs_500_parallel_mount_local.cmx: t/guestfs_500_parallel_mount_local.ml mlguestfs.cmxa + $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -package unix,threads -thread -linkpkg -c $< -o $@ + +noinst_LIBRARIES += libocamltestlib.a +libocamltestlib_a_SOURCES = t/exit.c +libocamltestlib_a_CFLAGS = $(libguestfsocaml_a_CFLAGS) + %.cmi: %.mli $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -package unix -c $< -o $(builddir)/$@ %.cmo: %.ml mlguestfs.cma diff --git a/ocaml/t/exit.c b/ocaml/t/exit.c new file mode 100644 index 00000000..ca392def --- /dev/null +++ b/ocaml/t/exit.c @@ -0,0 +1,44 @@ +/* libguestfs OCaml bindings + * Copyright (C) 2012 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., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + */ + +#include <config.h> + +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> + +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/misc.h> +#include <caml/mlvalues.h> + +value ocaml_guestfs__exit (value) Noreturn; + +/* _exit : int -> 'a (does not return) */ +value +ocaml_guestfs__exit (value statusv) +{ + CAMLparam1 (statusv); + int status = Int_val (statusv); + + _exit (status); + + /*NOTREACHED*/ + CAMLnoreturn; +} diff --git a/ocaml/t/guestfs_500_parallel_mount_local.ml b/ocaml/t/guestfs_500_parallel_mount_local.ml new file mode 100644 index 00000000..974c8cc9 --- /dev/null +++ b/ocaml/t/guestfs_500_parallel_mount_local.ml @@ -0,0 +1,197 @@ +(* libguestfs OCaml bindings + * Copyright (C) 2012 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +(* Test guestfs_mount_local, from a higher level language (it will + * mostly be used first from Python), in parallel threads. OCaml + * allows us to test this at a reasonable speed. + *) + +open Unix +open Printf + +let (//) = Filename.concat + +(* See [exit.c]. *) +external _exit : int -> 'a = "ocaml_guestfs__exit" + +(* Some settings. *) +let total_time = 60. (* seconds, excluding launch *) +let debug = true (* overview debugging messages *) +let min_threads = 2 +let mbytes_per_thread = 900 + +let rec main () = + Random.self_init (); + + (* Choose the number of threads based on the amount of free memory. *) + let nr_threads = + let mbytes = + let cmd = "LANG=C free -m | grep 'buffers/cache' | awk '{print $NF}'" in + let chan = open_process_in cmd in + let mbytes = input_line chan in + match close_process_in chan with + | WEXITED 0 -> Some (int_of_string mbytes) + | _ -> None in + match mbytes with + | None -> min_threads (* default *) + | Some mbytes -> max min_threads (mbytes / mbytes_per_thread) in + + let threads = ref [] in + for i = 1 to nr_threads do + let filename = sprintf "test%d.img" i in + let mp = sprintf "mp%d" i in + (try rmdir mp with Unix_error _ -> ()); + mkdir mp 0o700; + + if debug then eprintf "%s : starting thread\n%!" mp; + let t = Thread.create start_thread (filename, mp) in + threads := (t, filename, mp) :: !threads + done; + + (* Wait until the threads terminate and delete the files and mountpoints. *) + List.iter ( + fun (t, filename, mp) -> + Thread.join t; + + if debug then eprintf "%s : cleaning up thread\n%!" mp; + unlink filename; + rmdir mp + ) !threads; + + Gc.compact () + +and start_thread (filename, mp) = + (* Create a filesystem for the tests. *) + let g = new Guestfs.guestfs () in + + let fd = openfile filename [O_WRONLY;O_CREAT;O_NOCTTY;O_TRUNC] 0o666 in + ftruncate fd (500 * 1024 * 1024); + close fd; + + g#add_drive_opts filename; + g#launch (); + + g#part_disk "/dev/sda" "mbr"; + g#mkfs "ext2" "/dev/sda1"; + g#mount "/dev/sda1" "/"; + + (* Randomly mount the filesystem and repeat. Keep going until we + * finish the test. + *) + let start_t = time () in + let rec loop () = + let t = time () in + if t -. start_t < total_time then ( + if debug then eprintf "%s < mounting filesystem\n%!" mp; + g#mount_local mp; + + (* Run test in an exec'd subprocess. *) + let args = [| Sys.executable_name; "--test"; mp |] in + let pid = fork () in + if pid = 0 then ( (* child *) + try execv Sys.executable_name args + with exn -> prerr_endline (Printexc.to_string exn); _exit 1 + ); + + (* Run FUSE main loop. This processes requests until the + * subprocess unmounts the filesystem. + *) + g#mount_local_run (); + + let _, status = waitpid [] pid in + (match status with + | WEXITED 0 -> () + | WEXITED i -> + eprintf "test subprocess failed (exit code %d)\n" i; + exit 1 + | WSIGNALED i | WSTOPPED i -> + eprintf "test subprocess signaled/stopped (signal %d)\n" i; + exit 1 + ); + loop () + ) + in + loop (); + + g#close () + +(* This is run in a child program. *) +and test_mountpoint mp = + if debug then eprintf "%s | testing filesystem\n%!" mp; + + (* Run through the same set of tests repeatedly a number of times. + * The aim of this stress test is repeated mount/unmount, not testing + * FUSE itself, so we don't do much here. + *) + for pass = 0 to Random.int 32 do + mkdir (mp // "tmp.d") 0o700; + let chan = open_out (mp // "file") in + let s = String.make (Random.int (128 * 1024)) (Char.chr (Random.int 256)) in + output_string chan s; + close_out chan; + rename (mp // "tmp.d") (mp // "newdir"); + link (mp // "file") (mp // "newfile"); + if Random.int 32 = 0 then sleep 1; + rmdir (mp // "newdir"); + unlink (mp // "file"); + unlink (mp // "newfile") + done; + + if debug then eprintf "%s > unmounting filesystem\n%!" mp; + + unmount mp + +(* We may need to retry this a few times because of processes which + * run in the background jumping into mountpoints. Only display + * errors if it still fails after many retries. + *) +and unmount mp = + let logfile = sprintf "%s.fusermount.log" mp in + let unlink_logfile () = + try unlink logfile with Unix_error _ -> () + in + unlink_logfile (); + + let run_command () = + Sys.command (sprintf "fusermount -u %s >> %s 2>&1" + (Filename.quote mp) (Filename.quote logfile)) = 0 + in + + let rec loop tries = + if tries <= 5 then ( + if not (run_command ()) then ( + sleep 1; + loop (tries+1) + ) + ) else ( + ignore (Sys.command (sprintf "cat %s" (Filename.quote logfile))); + eprintf "fusermount: %s: failed, see earlier error messages\n" mp; + exit 1 + ) + in + loop 0; + + unlink_logfile () + +let () = + match Array.to_list Sys.argv with + | [ _; "--test"; mp ] -> test_mountpoint mp + | [ _ ] -> main () + | _ -> + eprintf "%s: unknown arguments given to program\n" Sys.executable_name; + exit 1 diff --git a/po/POTFILES.in b/po/POTFILES.in index 7cd55cab..40842ea4 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -172,6 +172,7 @@ inspector/virt-inspector.c java/com_redhat_et_libguestfs_GuestFS.c ocaml/guestfs_c.c ocaml/guestfs_c_actions.c +ocaml/t/exit.c perl/Guestfs.c perl/bindtests.pl perl/lib/Sys/Guestfs.pm |