Re: [Libguestfs] [PATCH 02/27] daemon: Allow parts of the daemon and APIs to be written in OCaml.

.gitignore | 6 +- Makefile.am | 2 +- common/mlutils/Makefile.am | 4 - daemon/Makefile.am | 103 +++++++++++++++++++++++-- daemon/chroot.ml | 85 +++++++++++++++++++++ daemon/chroot.mli | 35 +++++++++ daemon/daemon-c.c | 35 +++++++++ daemon/daemon.ml | 39 ++++++++++ daemon/guestfsd.c | 50 ++++++++++++ daemon/sysroot-c.c | 37 +++++++++ daemon/sysroot.ml | 19 +++++ daemon/sysroot.mli | 22 ++++++ daemon/utils.ml | 156 +++++++++++++++++++++++++++++++++++++ daemon/utils.mli | 65 ++++++++++++++++

diff --git a/daemon/Makefile.am b/daemon/Makefile.am index eedf09d52..40b770762 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

+OCAML_LIBS = \ + -lmlcutils \ + -lmlstdutils \ + -lmlhivex \ + -lcamlstr \ + -lunix \ + -l$(CAMLRUN) -ldl -lm

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/guestfsd.c b/daemon/guestfsd.c index b3f40628b..1d35991b6 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,46 @@ 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) +{

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) +{

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