This change allows parts of the daemon to be written in the OCaml programming language. I am using the ‘Main Program in C’ method along with ‘-output-obj’ to create an object file from the OCaml code / runtime, as described here: https://caml.inria.fr/pub/docs/manual-ocaml/intfc.html
Furthermore, change the generator to allow individual APIs to be implemented in OCaml. This is picked by setting: impl = OCaml <ocaml_function>; The generator creates ‘do_function’ (the same one you would have to write by hand in C), with the function calling the named ‘ocaml_function’ and dealing with marshalling/unmarshalling the OCaml parameters. Note that the OCaml compiler (either ocamlc or ocamlopt) is now required even for building from tarballs. --- .gitignore | 6 +- Makefile.am | 2 +- daemon/Makefile.am | 103 +++++++++++++++++++++++-- daemon/chroot.ml | 85 +++++++++++++++++++++ daemon/chroot.mli | 35 +++++++++ daemon/daemon-c.c | 35 +++++++++ daemon/daemon.ml | 39 ++++++++++ daemon/guestfsd.c | 45 +++++++++++ daemon/sysroot-c.c | 37 +++++++++ daemon/sysroot.ml | 19 +++++ daemon/sysroot.mli | 22 ++++++ daemon/utils.ml | 156 ++++++++++++++++++++++++++++++++++++++ daemon/utils.mli | 65 ++++++++++++++++ docs/guestfs-building.pod | 10 ++- docs/guestfs-hacking.pod | 7 ++ generator/actions.ml | 5 ++ generator/actions.mli | 4 + generator/daemon.ml | 187 ++++++++++++++++++++++++++++++++++++++++++++++ generator/daemon.mli | 3 + generator/main.ml | 6 ++ generator/types.ml | 7 +- 21 files changed, 866 insertions(+), 12 deletions(-) diff --git a/.gitignore b/.gitignore index 8afd06d0e..f37ca263a 100644 --- a/.gitignore +++ b/.gitignore @@ -164,20 +164,24 @@ Makefile.in /customize/test-settings-*.sh /customize/virt-customize /customize/virt-customize.1 +/daemon/.depend /daemon/actions.h +/daemon/callbacks.ml +/daemon/caml-stubs.c /daemon/dispatch.c /daemon/guestfsd /daemon/guestfsd.8 /daemon/guestfsd.exe +/daemon/lvm-tokenization.c /daemon/names.c /daemon/optgroups.c /daemon/optgroups.h -/daemon/lvm-tokenization.c /daemon/stamp-guestfsd.pod /daemon/structs-cleanups.c /daemon/structs-cleanups.h /daemon/stubs-?.c /daemon/stubs.h +/daemon/types.ml /depcomp /df/stamp-virt-df.pod /df/virt-df diff --git a/Makefile.am b/Makefile.am index 9122d44ac..1b091044a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -44,6 +44,7 @@ SUBDIRS += common/structs SUBDIRS += lib docs examples po # The daemon and the appliance. +SUBDIRS += common/mlutils if ENABLE_DAEMON SUBDIRS += daemon SUBDIRS += tests/daemon @@ -155,7 +156,6 @@ SUBDIRS += csharp # OCaml tools. Note 'common/ml*', 'mllib' and 'customize' contain # shared code used by other OCaml tools, so these must come first. if HAVE_OCAML -SUBDIRS += common/mlutils SUBDIRS += common/mlprogress SUBDIRS += common/mlvisit SUBDIRS += common/mlxml diff --git a/daemon/Makefile.am b/daemon/Makefile.am index db19594b8..c7375fb87 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -19,6 +19,7 @@ include $(top_srcdir)/subdir-rules.mk generator_built = \ actions.h \ + caml-stubs.c \ dispatch.c \ names.c \ lvm-tokenization.c \ @@ -31,13 +32,30 @@ generator_built = \ stubs-4.c \ stubs-5.c \ stubs-6.c \ - stubs.h + stubs.h \ + callbacks.ml \ + types.ml BUILT_SOURCES = \ - $(generator_built) + actions.h \ + caml-stubs.c \ + dispatch.c \ + names.c \ + lvm-tokenization.c \ + structs-cleanups.c \ + structs-cleanups.h \ + stubs-0.c \ + stubs-1.c \ + stubs-2.c \ + stubs-3.c \ + stubs-4.c \ + stubs-5.c \ + stubs-6.c \ + stubs.h EXTRA_DIST = \ - $(BUILT_SOURCES) \ + $(generator_built) \ + $(SOURCES_MLI) $(SOURCES_ML) \ guestfsd.pod if INSTALL_DAEMON @@ -61,6 +79,7 @@ guestfsd_SOURCES = \ blkid.c \ blockdev.c \ btrfs.c \ + caml-stubs.c \ cap.c \ checksum.c \ cleanups.c \ @@ -71,6 +90,7 @@ guestfsd_SOURCES = \ copy.c \ cpio.c \ cpmv.c \ + daemon-c.c \ daemon.h \ dd.c \ debug.c \ @@ -161,6 +181,7 @@ guestfsd_SOURCES = \ swap.c \ sync.c \ syslinux.c \ + sysroot-c.c \ tar.c \ tsk.c \ truncate.c \ @@ -176,10 +197,16 @@ guestfsd_SOURCES = \ zero.c \ zerofree.c +guestfsd_LDFLAGS = \ + -L$(shell $(OCAMLC) -where) \ + -L$(shell $(OCAMLC) -where)/hivex \ + -L../common/mlutils \ + -L../common/mlstdutils guestfsd_LDADD = \ ../common/errnostring/liberrnostring.la \ ../common/protocol/libprotocol.la \ ../common/utils/libutils.la \ + camldaemon.o \ $(ACL_LIBS) \ $(CAP_LIBS) \ $(YAJL_LIBS) \ @@ -198,9 +225,12 @@ guestfsd_LDADD = \ $(PCRE_LIBS) \ $(TSK_LIBS) \ $(RPC_LIBS) \ - $(YARA_LIBS) + $(YARA_LIBS) \ + $(OCAML_LIBS) guestfsd_CPPFLAGS = \ + -I$(shell $(OCAMLC) -where) \ + -I$(shell $(OCAMLC) -where)/hivex \ -I$(top_srcdir)/gnulib/lib \ -I$(top_builddir)/gnulib/lib \ -I$(top_srcdir)/lib \ @@ -220,6 +250,69 @@ guestfsd_CFLAGS = \ $(YAJL_CFLAGS) \ $(PCRE_CFLAGS) +# Parts of the daemon are written in OCaml. These are linked into a +# library and then linked to the daemon. See +# https://caml.inria.fr/pub/docs/manual-ocaml/intfc.html +SOURCES_MLI = \ + chroot.mli \ + sysroot.mli \ + utils.mli + +SOURCES_ML = \ + types.ml \ + utils.ml \ + sysroot.ml \ + chroot.ml \ + callbacks.ml \ + daemon.ml + +BOBJECTS = $(SOURCES_ML:.ml=.cmo) +XOBJECTS = $(BOBJECTS:.cmo=.cmx) + +OCAMLPACKAGES = \ + -package str,unix,hivex \ + -I $(top_srcdir)/common/mlstdutils \ + -I $(top_srcdir)/common/mlutils + +OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_FLAGS) + +if !HAVE_OCAMLOPT +OBJECTS = $(BOBJECTS) +CAMLRUN = camlrun +else +OBJECTS = $(XOBJECTS) +CAMLRUN = asmrun +endif +OCAML_LIBS = \ + -lmlcutils \ + -lmlstdutils \ + -lmlhivex \ + -lcamlstr \ + -lunix \ + -l$(CAMLRUN) -ldl -lm + +CLEANFILES += camldaemon.o + +camldaemon.o: $(OBJECTS) + $(OCAMLFIND) $(BEST) -output-obj -o $@ \ + $(OCAMLFLAGS) $(OCAMLPACKAGES) \ + -linkpkg mlcutils.$(MLARCHIVE) mlstdutils.$(MLARCHIVE) \ + $(OBJECTS) + +# OCaml dependencies. +depend: .depend + +.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) + rm -f $@ $@-t + $(OCAMLFIND) ocamldep -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlutils $^ | \ + $(SED) 's/ *$$//' | \ + $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ + $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ + sort > $@-t + mv $@-t $@ + +-include .depend + # Manual pages and HTML files for the website. if INSTALL_DAEMON man_MANS = guestfsd.8 @@ -241,4 +334,4 @@ stamp-guestfsd.pod: guestfsd.pod $< touch $@ -.PHONY: force +.PHONY: depend force diff --git a/daemon/chroot.ml b/daemon/chroot.ml new file mode 100644 index 000000000..40dfa1dde --- /dev/null +++ b/daemon/chroot.ml @@ -0,0 +1,85 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +open Printf +open Unix + +open Std_utils +open Unix_utils + +type t = { + name : string; + chroot : string; +} + +let create ?(name = prog) chroot = + { name = name; chroot = chroot } + +let f t func arg = + if verbose () then + eprintf "chroot: %s: running ‘%s’\n%!" t.chroot t.name; + + let rfd, wfd = pipe () in + + let pid = fork () in + if pid = 0 then ( + (* Child. *) + close rfd; + + chdir t.chroot; + chroot t.chroot; + + let ret = + try Either (func arg) + with exn -> Or exn in + + try + let chan = out_channel_of_descr wfd in + output_value chan ret; + Pervasives.flush chan; + Exit._exit 0 + with + exn -> + prerr_endline (Printexc.to_string exn); + Exit._exit 1 + ); + + (* Parent. *) + close wfd; + + let _, status = waitpid [] pid in + (match status with + | WEXITED 0 -> () + | WEXITED i -> + close rfd; + failwithf "chroot ‘%s’ exited with non-zero error %d" t.name i + | WSIGNALED i -> + close rfd; + failwithf "chroot ‘%s’ killed by signal %d" t.name i + | WSTOPPED i -> + close rfd; + failwithf "chroot ‘%s’ stopped by signal %d" t.name i + ); + + let chan = in_channel_of_descr rfd in + let ret = input_value chan in + close_in chan; + + match ret with + | Either ret -> ret + | Or exn -> raise exn diff --git a/daemon/chroot.mli b/daemon/chroot.mli new file mode 100644 index 000000000..eda3a785f --- /dev/null +++ b/daemon/chroot.mli @@ -0,0 +1,35 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +(** This is a generic module for running functions in a chroot. + The function runs in a forked subprocess too so that we can + restore the root afterwards. + + It handles passing the parmeter, forking, running the + function and marshalling the result or any exceptions. *) + +type t + +val create : ?name:string -> string -> t +(** Create a chroot handle. [?name] is an optional name used in + debugging and error messages. The string is the chroot + directory. *) + +val f : t -> ('a -> 'b) -> 'a -> 'b +(** Run a function in the chroot, returning the result or re-raising + any exception thrown. *) diff --git a/daemon/daemon-c.c b/daemon/daemon-c.c new file mode 100644 index 000000000..da382bc35 --- /dev/null +++ b/daemon/daemon-c.c @@ -0,0 +1,35 @@ +/* guestfs-inspection + * Copyright (C) 2017 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 <caml/mlvalues.h> + +#include "daemon.h" + +extern value guestfs_int_daemon_get_verbose_flag (value unitv); + +/* NB: This is a "noalloc" call. */ +value +guestfs_int_daemon_get_verbose_flag (value unitv) +{ + return Val_bool (verbose); +} diff --git a/daemon/daemon.ml b/daemon/daemon.ml new file mode 100644 index 000000000..45bac029a --- /dev/null +++ b/daemon/daemon.ml @@ -0,0 +1,39 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +open Printf + +external get_verbose_flag : unit -> bool = + "guestfs_int_daemon_get_verbose_flag" "noalloc" + +(* When guestfsd starts up, after initialization but before accepting + * messages, it calls 'caml_startup' which runs all initialization code + * in the OCaml modules, including this one. Therefore this is where + * we can place OCaml initialization code for the daemon. + *) +let () = + (* Connect the guestfsd [-v] (verbose) flag into 'verbose ()' + * used in OCaml code to print debugging messages. + *) + if get_verbose_flag () then ( + Std_utils.set_verbose (); + eprintf "OCaml daemon loaded\n%!" + ); + + (* Register the callbacks which are used to call OCaml code from C. *) + Callbacks.init_callbacks () diff --git a/daemon/guestfsd.c b/daemon/guestfsd.c index b3f40628b..05337b31c 100644 --- a/daemon/guestfsd.c +++ b/daemon/guestfsd.c @@ -56,6 +56,10 @@ #include <augeas.h> +#include <caml/callback.h> +#include <caml/mlvalues.h> +#include <caml/unixsupport.h> + #include "sockets.h" #include "c-ctype.h" #include "ignore-value.h" @@ -348,6 +352,9 @@ main (int argc, char *argv[]) */ udev_settle (); + /* Initialize the OCaml stubs. */ + caml_startup (argv); + /* Send the magic length message which indicates that * userspace is up inside the guest. */ @@ -1205,3 +1212,41 @@ cleanup_free_mountable (mountable_t *mountable) free (mountable->volume); } } + +/* Convert an OCaml exception to a reply_with_error_errno call + * as best we can. + */ +extern void ocaml_exn_to_reply_with_error (const char *func, value exn); + +void +ocaml_exn_to_reply_with_error (const char *func, value exn) +{ + const char *exn_name; + + /* This is not the official way to do this, but I could not get the + * official way to work, and this way does work. See + * http://caml.inria.fr/pub/ml-archives/caml-list/2006/05/097f63cfb39a80418f95c70c3c520aa8.en.html + * http://caml.inria.fr/pub/ml-archives/caml-list/2009/06/797e2f797f57b8ea2a2c0e431a2df312.en.html + */ + exn_name = String_val (Field (Field (exn, 0), 0)); + if (verbose) + fprintf (stderr, "ocaml_exn: '%s' raised '%s' exception\n", + func, exn_name); + + if (STREQ (exn_name, "Unix.Unix_error")) { + int errcode = code_of_unix_error (Field (exn, 1)); + reply_with_perror_errno (errcode, "%s: %s", + String_val (Field (exn, 2)), + String_val (Field (exn, 3))); + } + else if (STREQ (exn_name, "Failure")) + reply_with_error ("%s", String_val (Field (exn, 1))); + else if (STREQ (exn_name, "Sys_error")) + reply_with_error ("%s", String_val (Field (exn, 1))); + else if (STREQ (exn_name, "Invalid_argument")) + reply_with_error ("invalid argument: %s", + String_val (Field (exn, 1))); + else + reply_with_error ("internal error: %s: unknown exception thrown: %s", + func, exn_name); +} diff --git a/daemon/sysroot-c.c b/daemon/sysroot-c.c new file mode 100644 index 000000000..ad31d36ee --- /dev/null +++ b/daemon/sysroot-c.c @@ -0,0 +1,37 @@ +/* guestfs-inspection + * Copyright (C) 2017 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 <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/mlvalues.h> + +#include "daemon.h" + +extern value guestfs_int_daemon_sysroot (value unitv); + +value +guestfs_int_daemon_sysroot (value unitv) +{ + return caml_copy_string (sysroot); +} diff --git a/daemon/sysroot.ml b/daemon/sysroot.ml new file mode 100644 index 000000000..ecf0d7362 --- /dev/null +++ b/daemon/sysroot.ml @@ -0,0 +1,19 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +external sysroot : unit -> string = "guestfs_int_daemon_sysroot" diff --git a/daemon/sysroot.mli b/daemon/sysroot.mli new file mode 100644 index 000000000..88f976476 --- /dev/null +++ b/daemon/sysroot.mli @@ -0,0 +1,22 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val sysroot : unit -> string +(** Return the current sysroot path where filesystems are mounted. + This comes from the daemon command line ([-r] option) or a built + in default. *) diff --git a/daemon/utils.ml b/daemon/utils.ml new file mode 100644 index 000000000..7630a5534 --- /dev/null +++ b/daemon/utils.ml @@ -0,0 +1,156 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +open Unix +open Printf + +open Std_utils + +let prog_exists prog = + try ignore (which prog); true + with Executable_not_found _ -> false + +let commandr prog args = + if verbose () then + eprintf "command: %s %s\n%!" + prog (String.concat " " args); + + let argv = Array.of_list (prog :: args) in + + let stdout_file, stdout_chan = Filename.open_temp_file "cmd" ".out" in + let stderr_file, stderr_chan = Filename.open_temp_file "cmd" ".err" in + let stdout_fd = descr_of_out_channel stdout_chan in + let stderr_fd = descr_of_out_channel stderr_chan in + let stdin_fd = openfile "/dev/null" [O_RDONLY] 0 in + + let pid = fork () in + if pid = 0 then ( + (* Child process. *) + dup2 stdin_fd stdin; + close stdin_fd; + dup2 stdout_fd stdout; + close stdout_fd; + dup2 stderr_fd stderr; + close stderr_fd; + + execvp prog argv + ); + + (* Parent process. *) + close stdin_fd; + close stdout_fd; + close stderr_fd; + let _, status = waitpid [] pid in + let r = + match status with + | WEXITED i -> i + | WSIGNALED i -> + failwithf "external command ‘%s’ killed by signal %d" prog i + | WSTOPPED i -> + failwithf "external command ‘%s’ stopped by signal %d" prog i in + + if verbose () then + eprintf "command: %s returned %d\n" prog r; + + let stdout = read_whole_file stdout_file in + let stderr = read_whole_file stderr_file in + + if verbose () then ( + if stdout <> "" then ( + eprintf "command: %s: stdout:\n%s%!" prog stdout; + if not (String.is_suffix stdout "\n") then eprintf "\n%!" + ); + if stderr <> "" then ( + eprintf "command: %s: stderr:\n%s%!" prog stderr; + if not (String.is_suffix stderr "\n") then eprintf "\n%!" + ) + ); + + (* Strip trailing \n from stderr but NOT from stdout. *) + let stderr = + let n = String.length stderr in + if n > 0 && stderr.[n-1] = '\n' then + String.sub stderr 0 (n-1) + else + stderr in + + (r, stdout, stderr) + +let command prog args = + let r, stdout, stderr = commandr prog args in + if r <> 0 then + failwithf "%s exited with status %d: %s" prog r stderr; + stdout + +let udev_settle ?filename () = + let args = ref [] in + if verbose () then + push_back args "--debug"; + push_back args "settle"; + (match filename with + | None -> () + | Some filename -> + push_back args "-E"; + push_back args filename + ); + let args = !args in + let r, _, err = commandr "udevadm" args in + if r <> 0 then + eprintf "udevadm settle: %s\n" err + +let root_device = lazy ((stat "/").st_dev) + +let is_root_device_stat statbuf = + statbuf.st_rdev = Lazy.force root_device + +let is_root_device device = + udev_settle ~filename:device (); + try + let statbuf = stat device in + is_root_device_stat statbuf + with + Unix_error (err, func, arg) -> + eprintf "is_root_device: %s: %s: %s: %s\n" + device func arg (error_message err); + false + +let proc_unmangle_path path = + let n = String.length path in + let b = Buffer.create n in + let rec loop i = + if i < n-3 && path.[i] = '\\' then ( + let to_int c = Char.code c - Char.code '0' in + let v = + (to_int path.[i+1] lsl 6) lor + (to_int path.[i+2] lsl 3) lor + to_int path.[i+3] in + Buffer.add_char b (Char.chr v); + loop (i+4) + ) + else if i < n then ( + Buffer.add_char b path.[i]; + loop (i+1) + ) + else + Buffer.contents b + in + loop 0 + +let is_small_file path = + is_regular_file path && + (stat path).st_size <= 2 * 1048 * 1024 diff --git a/daemon/utils.mli b/daemon/utils.mli new file mode 100644 index 000000000..57f703c6c --- /dev/null +++ b/daemon/utils.mli @@ -0,0 +1,65 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val prog_exists : string -> bool +(** Return true iff the program is found on [$PATH]. *) + +val udev_settle : ?filename:string -> unit -> unit +(** + * LVM and other commands aren't synchronous, especially when udev is + * involved. eg. You can create or remove some device, but the + * [/dev] device node won't appear until some time later. This means + * that you get an error if you run one command followed by another. + * + * Use [udevadm settle] after certain commands, but don't be too + * fussed if it fails. + * + * The optional [?filename] passes the [udevadm settle -E filename] + * option, which means udevadm stops waiting as soon as the named + * file is created (or if it exists at the start). + *) + +val is_root_device : string -> bool +(** Return true if this is the root (appliance) device. *) + +val is_root_device_stat : Unix.stats -> bool +(** As for {!is_root_device} but operates on a statbuf instead of + a device name. *) + +val proc_unmangle_path : string -> string +(** Reverse kernel path escaping done in fs/seq_file.c:mangle_path. + This is inconsistently used for /proc fields. *) + +val command : string -> string list -> string +(** Run an external command without using the shell, and collect + stdout and stderr separately. Returns stdout if the command + runs successfully. + + On failure of the command, this throws an exception containing + the stderr from the command. *) + +val commandr : string -> string list -> (int * string * string) +(** Run an external command without using the shell, and collect + stdout and stderr separately. + + Returns [status, stdout, stderr]. As with the C function in + [daemon/command.c], this strips the trailing [\n] from stderr, + but {b not} from stdout. *) + +val is_small_file : string -> bool +(** Return true if the path is a small regular file. *) diff --git a/docs/guestfs-building.pod b/docs/guestfs-building.pod index 0f9ed2893..4e1ff7df4 100644 --- a/docs/guestfs-building.pod +++ b/docs/guestfs-building.pod @@ -120,8 +120,7 @@ I<Required>. Part of Perl core. =item OCaml findlib -I<Required> if compiling from git. -Optional (but recommended) if compiling from tarball. +I<Required>. =item autoconf @@ -594,8 +593,11 @@ See L</USING A PREBUILT BINARY APPLIANCE> below. Disable specific language bindings, even if C<./configure> finds all the necessary libraries are installed so that they could be compiled. -Note that disabling OCaml or Perl will have the knock-on effect of -disabling large numbers of virt tools and parts of the test suite. +Note that disabling Perl will have the knock-on effect of disabling +parts of the test suite and some tools. + +Disabling OCaml only disables the bindings and several virt tools. +OCaml is required to build libguestfs. =item B<--disable-fuse> diff --git a/docs/guestfs-hacking.pod b/docs/guestfs-hacking.pod index bfbe4526d..25f4bfa94 100644 --- a/docs/guestfs-hacking.pod +++ b/docs/guestfs-hacking.pod @@ -416,6 +416,13 @@ in the C<lib/> directory. In either case, use another function as an example of what to do. +=item 3. + +As an alternative to step 2: Since libguestfs 1.37.15, daemon actions +can be implemented in OCaml. You have to set the C<impl = OCaml ...> +flag in the generator. Take a look at F<daemon/file.ml> for an +example. + =back After making these changes, use C<make> to compile. diff --git a/generator/actions.ml b/generator/actions.ml index a9b3b5906..75742397a 100644 --- a/generator/actions.ml +++ b/generator/actions.ml @@ -185,6 +185,11 @@ let is_fish { visibility = v; style = (_, args, _) } = not (List.exists (function Pointer _ -> true | _ -> false) args) let fish_functions = List.filter is_fish +let is_ocaml_function = function + | { impl = OCaml _ } -> true + | { impl = C } -> false +let impl_ocaml_functions = List.filter is_ocaml_function + (* In some places we want the functions to be displayed sorted * alphabetically, so this is useful: *) diff --git a/generator/actions.mli b/generator/actions.mli index 0d326b609..82217cbdc 100644 --- a/generator/actions.mli +++ b/generator/actions.mli @@ -40,6 +40,10 @@ val internal_functions : Types.action list -> Types.action list val fish_functions : Types.action list -> Types.action list (** Filter {!actions}, returning only functions in guestfish. *) +val impl_ocaml_functions : Types.action list -> Types.action list +(** Filter {!actions}, returning only functions implemented + in OCaml (in the daemon). *) + val documented_functions : Types.action list -> Types.action list (** Filter {!actions}, returning only functions requiring documentation. *) diff --git a/generator/daemon.ml b/generator/daemon.ml index 2ae462864..ac410b733 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -471,6 +471,193 @@ let generate_daemon_stubs actions () = pr "}\n\n"; ) (actions |> daemon_functions |> sort) +let generate_daemon_caml_types_ml () = + generate_header OCamlStyle GPLv2plus + +let generate_daemon_caml_callbacks_ml () = + generate_header OCamlStyle GPLv2plus; + + if actions |> impl_ocaml_functions <> [] then ( + pr "let init_callbacks () =\n"; + pr " (* Initialize callbacks to OCaml code. *)\n"; + List.iter ( + fun ({ name = name; style = ret, args, optargs } as f) -> + let ocaml_function = + match f.impl with + | OCaml f -> f + | C -> assert false in + + pr " Callback.register %S %s;\n" ocaml_function ocaml_function + ) (actions |> impl_ocaml_functions |> sort) + ) + else + pr "let init_callbacks () = ()\n" + +(* Generate stubs for the functions implemented in OCaml. + * Basically we implement the do_<name> function here, and + * have it call out to OCaml code. + *) +let generate_daemon_caml_stubs () = + generate_header CStyle GPLv2plus; + + pr "\ +#include <config.h> + +#include <stdio.h> +#include <stdlib.h> +#include <stdbool.h> +#include <string.h> +#include <inttypes.h> +#include <errno.h> + +#include <caml/alloc.h> +#include <caml/callback.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/mlvalues.h> + +#include \"daemon.h\" +#include \"actions.h\" + +/* This is not declared in <daemon.h> because we don't want to + * include the OCaml headers (to get 'value') for the whole daemon. + */ +extern void ocaml_exn_to_reply_with_error (const char *func, value exn); + +"; + + List.iter ( + fun ({ name = name; style = ret, args, optargs } as f) -> + let ocaml_function = + match f.impl with + | OCaml f -> f + | C -> assert false in + + pr "/* Wrapper for OCaml function ‘%s’. */\n" ocaml_function; + + let args_do_function = args @ args_of_optargs optargs in + let args_do_function = + List.filter (function + | String ((FileIn|FileOut), _) -> false | _ -> true) + args_do_function in + let style = ret, args_do_function, [] in + generate_prototype ~extern:false ~semicolon:false + ~single_line:false ~newline:false + ~in_daemon:true ~prefix:"do_" + name style; + pr "\n"; + + let add_unit_arg = + let args = List.filter + (function + | String ((FileIn|FileOut), _) -> false | _ -> true) + args in + args = [] in + let nr_args = List.length args_do_function in + + pr "{\n"; + pr " static value *cb = NULL;\n"; + pr " CAMLparam0 ();\n"; + pr " CAMLlocal2 (v, retv);\n"; + pr " CAMLlocalN (args, %d);\n" + (nr_args + if add_unit_arg then 1 else 0); + pr "\n"; + pr " if (cb == NULL)\n"; + pr " cb = caml_named_value (\"%s\");\n" ocaml_function; + pr "\n"; + + (* Construct the actual call, but note that we want to pass + * the optional arguments first in the list. + *) + let i = ref 0 in + List.iter ( + fun optarg -> + let n = name_of_optargt optarg in + let uc_n = String.uppercase_ascii n in + + (* optargs are all passed as [None|Some _] *) + pr " if ((optargs_bitmask & %s_%s_BITMASK) == 0)\n" + f.c_optarg_prefix uc_n; + pr " args[%d] = Val_int (0); /* None */\n" !i; + pr " else {\n"; + pr " v = "; + (match optarg with + | OBool _ -> + pr "Val_bool (%s)" n; + | OInt _ -> assert false + | OInt64 _ -> assert false + | OString _ -> assert false + | OStringList _ -> assert false + ); + pr ";\n"; + pr " args[%d] = caml_alloc (1, 0);\n" !i; + pr " Store_field (args[%d], 0, v);\n" !i; + pr " }\n"; + incr i + ) optargs; + List.iter ( + fun arg -> + pr " args[%d] = " !i; + (match arg with + | Bool n -> pr "Val_bool (%s)" n + | Int n -> pr "Val_int (%s)" n + | Int64 n -> pr "caml_copy_int64 (%s)" n + | String (_, n) -> pr "caml_copy_string (%s)" n + | OptString _ -> assert false + | StringList _ -> assert false + | BufferIn _ -> assert false + | Pointer _ -> assert false + ); + pr ";\n"; + incr i + ) args; + assert (!i = nr_args); + + (* If there are no non-optional arguments, we add a unit arg. *) + if add_unit_arg then + pr " args[%d] = Val_unit;\n" !i; + + pr " retv = caml_callbackN_exn (*cb, %d, args);\n" + (nr_args + if add_unit_arg then 1 else 0); + pr "\n"; + pr " if (Is_exception_result (retv)) {\n"; + pr " retv = Extract_exception (retv);\n"; + pr " ocaml_exn_to_reply_with_error (%S, retv);\n" name; + (match errcode_of_ret ret with + | `CannotReturnError -> + pr " CAMLreturn0;\n" + | `ErrorIsMinusOne -> + pr " CAMLreturnT (int, -1);\n" + | `ErrorIsNULL -> + pr " CAMLreturnT (void *, NULL);\n" + ); + pr " }\n"; + pr "\n"; + + (match ret with + | RErr -> assert false + | RInt _ -> assert false + | RInt64 _ -> assert false + | RBool _ -> assert false + | RConstString _ -> assert false + | RConstOptString _ -> assert false + | RString _ -> + pr " char *ret = strdup (String_val (retv));\n"; + pr " if (ret == NULL) {\n"; + pr " reply_with_perror (\"strdup\");\n"; + pr " CAMLreturnT (char *, NULL);\n"; + pr " }\n"; + pr " CAMLreturnT (char *, ret); /* caller frees */\n" + | RStringList _ -> assert false + | RStruct _ -> assert false + | RStructList _ -> assert false + | RHashtable _ -> assert false + | RBufferOut _ -> assert false + ); + pr "}\n"; + pr "\n" + ) (actions |> impl_ocaml_functions |> sort) + let generate_daemon_dispatch () = generate_header CStyle GPLv2plus; diff --git a/generator/daemon.mli b/generator/daemon.mli index ff008bf85..314a6da8f 100644 --- a/generator/daemon.mli +++ b/generator/daemon.mli @@ -19,6 +19,9 @@ val generate_daemon_actions_h : unit -> unit val generate_daemon_stubs_h : unit -> unit val generate_daemon_stubs : Types.action list -> unit -> unit +val generate_daemon_caml_stubs : unit -> unit +val generate_daemon_caml_callbacks_ml : unit -> unit +val generate_daemon_caml_types_ml : unit -> unit val generate_daemon_dispatch : unit -> unit val generate_daemon_lvm_tokenization : unit -> unit val generate_daemon_names : unit -> unit diff --git a/generator/main.ml b/generator/main.ml index 33fe2b2ee..a6c805e2e 100644 --- a/generator/main.ml +++ b/generator/main.ml @@ -133,6 +133,12 @@ Run it from the top source directory using the command Daemon.generate_daemon_stubs_h; output_to_subset "daemon/stubs-%d.c" Daemon.generate_daemon_stubs; + output_to "daemon/caml-stubs.c" + Daemon.generate_daemon_caml_stubs; + output_to "daemon/callbacks.ml" + Daemon.generate_daemon_caml_callbacks_ml; + output_to "daemon/types.ml" + Daemon.generate_daemon_caml_types_ml; output_to "daemon/dispatch.c" Daemon.generate_daemon_dispatch; output_to "daemon/names.c" diff --git a/generator/types.ml b/generator/types.ml index 740bc7750..fb6c3bc06 100644 --- a/generator/types.ml +++ b/generator/types.ml @@ -379,11 +379,16 @@ type deprecated_by = | Replaced_by of string (* replaced by another function *) | Deprecated_no_replacement (* deprecated with no replacement *) +type impl = + | C (* implemented in C by "do_<name>" *) + | OCaml of string (* implemented in OCaml by named function *) + (* Type of an action as declared in Actions module. *) type action = { name : string; (* name, not including "guestfs_" *) added : version; (* which version was the API first added *) style : style; (* args and return value *) + impl : impl; (* implementation language (C or OCaml) *) proc_nr : int option; (* proc number, None for non-daemon *) tests : c_api_tests; (* C API tests *) test_excuse : string; (* if there's no tests ... *) @@ -439,7 +444,7 @@ type action = { *) let defaults = { name = ""; added = (-1,-1,-1); - style = RErr, [], []; proc_nr = None; + style = RErr, [], []; impl = C; proc_nr = None; tests = []; test_excuse = ""; shortdesc = ""; longdesc = ""; protocol_limit_warning = false; fish_alias = []; -- 2.13.0 _______________________________________________ Libguestfs mailing list Libguestfs@redhat.com https://www.redhat.com/mailman/listinfo/libguestfs