[Libguestfs] [PATCH v3 02/19] generator: Allow APIs to be implemented in OCaml.

Richard W.M. Jones rjones at redhat.com
Mon Jun 5 16:41:02 UTC 2017


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.
---
 .gitignore               |   3 +
 daemon/Makefile.am       |  36 ++++++++--
 daemon/chroot.ml         |  85 ++++++++++++++++++++++
 daemon/chroot.mli        |  35 +++++++++
 daemon/daemon-c.c        |  35 +++++++++
 daemon/daemon.ml         |  22 ++++++
 daemon/guestfsd.c        |  40 +++++++++++
 daemon/sysroot-c.c       |  37 ++++++++++
 daemon/sysroot.ml        |  19 +++++
 daemon/sysroot.mli       |  22 ++++++
 daemon/utils.ml          | 156 ++++++++++++++++++++++++++++++++++++++++
 daemon/utils.mli         |  65 +++++++++++++++++
 docs/guestfs-hacking.pod |   7 ++
 generator/actions.ml     |   5 ++
 generator/actions.mli    |   4 ++
 generator/daemon.ml      | 183 +++++++++++++++++++++++++++++++++++++++++++++++
 generator/daemon.mli     |   3 +
 generator/main.ml        |   6 ++
 generator/types.ml       |   7 +-
 19 files changed, 765 insertions(+), 5 deletions(-)
 create mode 100644 daemon/chroot.ml
 create mode 100644 daemon/chroot.mli
 create mode 100644 daemon/daemon-c.c
 create mode 100644 daemon/sysroot-c.c
 create mode 100644 daemon/sysroot.ml
 create mode 100644 daemon/sysroot.mli
 create mode 100644 daemon/utils.ml
 create mode 100644 daemon/utils.mli

diff --git a/.gitignore b/.gitignore
index 08d6e1863..69b824a74 100644
--- a/.gitignore
+++ b/.gitignore
@@ -156,6 +156,8 @@ Makefile.in
 /customize/virt-customize.1
 /daemon/.depend
 /daemon/actions.h
+/daemon/callbacks.ml
+/daemon/caml-stubs.c
 /daemon/common_utils.ml
 /daemon/common_utils.mli
 /daemon/dispatch.c
@@ -174,6 +176,7 @@ Makefile.in
 /daemon/structs-cleanups.h
 /daemon/stubs-?.c
 /daemon/stubs.h
+/daemon/types.ml
 /daemon/unix_utils-c.c
 /daemon/unix_utils.ml
 /daemon/unix_utils.mli
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 3054fc444..30d24f1ad 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,29 @@ 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
 
@@ -60,6 +77,7 @@ guestfsd_SOURCES = \
 	blkid.c \
 	blockdev.c \
 	btrfs.c \
+	caml-stubs.c \
 	cap.c \
 	checksum.c \
 	cleanups.c \
@@ -71,6 +89,7 @@ guestfsd_SOURCES = \
 	copy.c \
 	cpio.c \
 	cpmv.c \
+	daemon-c.c \
 	daemon.h \
 	dd.c \
 	debug.c \
@@ -161,6 +180,7 @@ guestfsd_SOURCES = \
 	swap.c \
 	sync.c \
 	syslinux.c \
+	sysroot-c.c \
 	tar.c \
 	tsk.c \
 	truncate.c \
@@ -229,13 +249,21 @@ guestfsd_CFLAGS = \
 # library and then linked to the daemon.  See
 # https://caml.inria.fr/pub/docs/manual-ocaml/intfc.html
 SOURCES_MLI = \
+	chroot.mli \
 	common_utils.mli \
-	unix_utils.mli
+	sysroot.mli \
+	unix_utils.mli \
+	utils.mli
 
 SOURCES_ML = \
 	guestfs_config.ml \
 	unix_utils.ml \
 	common_utils.ml \
+	types.ml \
+	utils.ml \
+	sysroot.ml \
+	chroot.ml \
+	callbacks.ml \
 	daemon.ml
 
 BOBJECTS = $(SOURCES_ML:.ml=.cmo)
diff --git a/daemon/chroot.ml b/daemon/chroot.ml
new file mode 100644
index 000000000..14dcbc494
--- /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 Common_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
index 27d77a161..5a103f6a6 100644
--- a/daemon/daemon.ml
+++ b/daemon/daemon.ml
@@ -15,3 +15,25 @@
  * 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 (
+    Common_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 02fc27d32..9b6ae02b1 100644
--- a/daemon/guestfsd.c
+++ b/daemon/guestfsd.c
@@ -57,6 +57,8 @@
 #include <augeas.h>
 
 #include <caml/callback.h>
+#include <caml/mlvalues.h>
+#include <caml/unixsupport.h>
 
 #include "sockets.h"
 #include "c-ctype.h"
@@ -1274,3 +1276,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..3a5363063
--- /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 Common_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-hacking.pod b/docs/guestfs-hacking.pod
index 098869bbd..2d3eb46c6 100644
--- a/docs/guestfs-hacking.pod
+++ b/docs/guestfs-hacking.pod
@@ -386,6 +386,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 2722f3dcd..db69321e4 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 84686973c..1b5db4c4c 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -471,6 +471,189 @@ 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;
+
+  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)
+
+(* 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 d4316c085..cb39cb610 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




More information about the Libguestfs mailing list