[Libguestfs] [PATCH v2 01/23] daemon: Allow parts of the daemon and APIs to be written in OCaml.
Richard W.M. Jones
rjones at redhat.com
Fri Jul 21 20:36:05 UTC 2017
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.
---
.gitignore | 7 +-
Makefile.am | 2 +-
common/mlutils/Makefile.am | 4 -
daemon/Makefile.am | 121 +++++++++++++---
daemon/chroot.ml | 85 ++++++++++++
daemon/chroot.mli | 38 +++++
daemon/daemon-c.c | 203 +++++++++++++++++++++++++++
daemon/daemon-c.h | 38 +++++
daemon/daemon.ml | 39 ++++++
daemon/guestfsd.c | 5 +
daemon/sysroot-c.c | 37 +++++
daemon/sysroot.ml | 23 ++++
daemon/sysroot.mli | 25 ++++
daemon/utils.ml | 160 +++++++++++++++++++++
daemon/utils.mli | 72 ++++++++++
docs/C_SOURCE_FILES | 4 +
docs/guestfs-hacking.pod | 7 +
generator/OCaml.ml | 8 ++
generator/OCaml.mli | 1 +
generator/actions.ml | 5 +
generator/actions.mli | 4 +
generator/daemon.ml | 337 ++++++++++++++++++++++++++++++++++++++++++++-
generator/daemon.mli | 3 +
generator/main.ml | 8 ++
generator/types.ml | 7 +-
25 files changed, 1215 insertions(+), 28 deletions(-)
diff --git a/.gitignore b/.gitignore
index bbd9284c6..4f10327c4 100644
--- a/.gitignore
+++ b/.gitignore
@@ -165,20 +165,25 @@ 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/structs.ml
/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 a411b0b7b..84b00393d 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/common/mlutils/Makefile.am b/common/mlutils/Makefile.am
index 94b2187eb..f29ffc062 100644
--- a/common/mlutils/Makefile.am
+++ b/common/mlutils/Makefile.am
@@ -35,8 +35,6 @@ SOURCES_C = \
c_utils-c.c \
unix_utils-c.c
-if HAVE_OCAML
-
# We pretend that we're building a C library. automake handles the
# compilation of the C sources for us. At the end we take the C
# objects and OCaml objects and link them into the OCaml library.
@@ -150,6 +148,4 @@ depend: .depend
-include .depend
-endif
-
.PHONY: depend docs
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index eedf09d52..67a26de06 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -17,27 +17,31 @@
include $(top_srcdir)/subdir-rules.mk
-generator_built = \
- actions.h \
- 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
-
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 = \
+generator_built = \
$(BUILT_SOURCES) \
+ callbacks.ml \
+ types.ml
+
+EXTRA_DIST = \
+ $(generator_built) \
+ $(SOURCES_MLI) $(SOURCES_ML) \
guestfsd.pod
if INSTALL_DAEMON
@@ -61,6 +65,7 @@ guestfsd_SOURCES = \
blkid.c \
blockdev.c \
btrfs.c \
+ caml-stubs.c \
cap.c \
checksum.c \
cleanups.c \
@@ -71,6 +76,8 @@ guestfsd_SOURCES = \
copy.c \
cpio.c \
cpmv.c \
+ daemon-c.c \
+ daemon-c.h \
daemon.h \
dd.c \
debug.c \
@@ -161,6 +168,7 @@ guestfsd_SOURCES = \
swap.c \
sync.c \
syslinux.c \
+ sysroot-c.c \
tar.c \
tsk.c \
truncate.c \
@@ -176,10 +184,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 +212,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 +237,70 @@ 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 \
+ structs.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 +322,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..3364cd20b
--- /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 = "<unnamed>") ?(chroot = Sysroot.sysroot ()) () =
+ { 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..33f53ba18
--- /dev/null
+++ b/daemon/chroot.mli
@@ -0,0 +1,38 @@
+(* 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 parameter, forking, running the
+ function and marshalling the result or any exceptions. *)
+
+type t
+
+val create : ?name:string -> ?chroot:string -> unit -> t
+(** Create a chroot handle.
+
+ [?name] is an optional name used in debugging and error messages.
+
+ [?chroot] is the optional chroot directory. This parameter
+ defaults to [Sysroot.sysroot ()]. *)
+
+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..cbb3d8918
--- /dev/null
+++ b/daemon/daemon-c.c
@@ -0,0 +1,203 @@
+/* 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/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/unixsupport.h>
+
+#include "daemon.h"
+#include "daemon-c.h"
+
+/* Convert an OCaml exception to a reply_with_error_errno call
+ * as best we can.
+ */
+void
+guestfs_int_daemon_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
+ */
+ if (Tag_val (Field (exn, 0)) == String_tag)
+ /* For End_of_file and a few other constant exceptions. */
+ exn_name = String_val (Field (exn, 0));
+ else
+ /* For most exceptions. */
+ 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: unhandled exception thrown: %s",
+ func, exn_name);
+}
+
+/* NB: This is a "noalloc" call. */
+value
+guestfs_int_daemon_get_verbose_flag (value unitv)
+{
+ return Val_bool (verbose);
+}
+
+/* Implement String (Mountable, _) parameter. */
+value
+guestfs_int_daemon_copy_mountable (const mountable_t *mountable)
+{
+ CAMLparam0 ();
+ CAMLlocal4 (r, typev, devicev, volumev);
+
+ switch (mountable->type) {
+ case MOUNTABLE_DEVICE:
+ typev = Val_int (0); /* MountableDevice */
+ break;
+ case MOUNTABLE_PATH:
+ typev = Val_int (1); /* MountablePath */
+ break;
+ case MOUNTABLE_BTRFSVOL:
+ volumev = caml_copy_string (mountable->volume);
+ typev = caml_alloc (1, 0); /* MountableBtrfsVol */
+ Store_field (typev, 0, volumev);
+ }
+
+ devicev = caml_copy_string (mountable->device);
+
+ r = caml_alloc_tuple (2);
+ Store_field (r, 0, typev);
+ Store_field (r, 1, devicev);
+
+ CAMLreturn (r);
+}
+
+/* Implement RStringList. */
+char **
+guestfs_int_daemon_return_string_list (value retv)
+{
+ CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
+ value v;
+
+ while (retv != Val_int (0)) {
+ v = Field (retv, 0);
+ if (add_string (&ret, String_val (v)) == -1)
+ return NULL;
+ retv = Field (retv, 1);
+ }
+
+ if (end_stringsbuf (&ret) == -1)
+ return NULL;
+
+ return take_stringsbuf (&ret); /* caller frees */
+}
+
+/* Implement RString (RMountable, _). */
+char *
+guestfs_int_daemon_return_string_mountable (value retv)
+{
+ value typev = Field (retv, 0);
+ value devicev = Field (retv, 1);
+ value subvolv;
+ char *ret;
+
+ if (Is_long (typev)) { /* MountableDevice or MountablePath */
+ ret = strdup (String_val (devicev));
+ if (ret == NULL)
+ reply_with_perror ("strdup");
+ return ret;
+ }
+ else { /* MountableBtrfsVol of subvol */
+ subvolv = Field (typev, 0);
+ if (asprintf (&ret, "btrfsvol:%s/%s",
+ String_val (devicev), String_val (subvolv)) == -1)
+ reply_with_perror ("asprintf");
+ return ret;
+ }
+}
+
+/* Implement RHashtable (RPlainString, RPlainString, _). */
+char **
+guestfs_int_daemon_return_hashtable_string_string (value retv)
+{
+ CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
+ value v, sv;
+
+ while (retv != Val_int (0)) {
+ v = Field (retv, 0); /* (string, string) */
+ sv = Field (v, 0); /* string */
+ if (add_string (&ret, String_val (sv)) == -1)
+ return NULL;
+ sv = Field (v, 1); /* string */
+ if (add_string (&ret, String_val (sv)) == -1)
+ return NULL;
+ retv = Field (retv, 1);
+ }
+
+ if (end_stringsbuf (&ret) == -1)
+ return NULL;
+
+ return take_stringsbuf (&ret); /* caller frees */
+}
+
+/* Implement RHashtable (RMountable, RPlainString, _). */
+char **
+guestfs_int_daemon_return_hashtable_mountable_string (value retv)
+{
+ CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
+ value v, mv, sv;
+ char *m;
+
+ while (retv != Val_int (0)) {
+ v = Field (retv, 0); /* (Mountable.t, string) */
+ mv = Field (v, 0); /* Mountable.t */
+ m = guestfs_int_daemon_return_string_mountable (mv);
+ if (m == NULL)
+ return NULL;
+ if (add_string_nodup (&ret, m) == -1)
+ return NULL;
+ sv = Field (v, 1); /* string */
+ if (add_string (&ret, String_val (sv)) == -1)
+ return NULL;
+ retv = Field (retv, 1);
+ }
+
+ if (end_stringsbuf (&ret) == -1)
+ return NULL;
+
+ return take_stringsbuf (&ret); /* caller frees */
+}
diff --git a/daemon/daemon-c.h b/daemon/daemon-c.h
new file mode 100644
index 000000000..1b9f102ff
--- /dev/null
+++ b/daemon/daemon-c.h
@@ -0,0 +1,38 @@
+/* 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.
+ */
+
+/* This file is separate from <daemon.h> because we don't want to
+ * include the OCaml headers (to get 'value') for the whole daemon.
+ */
+
+#ifndef GUESTFSD_DAEMON_C_H
+#define GUESTFSD_DAEMON_C_H
+
+#include "daemon.h"
+
+#include <caml/mlvalues.h>
+
+extern value guestfs_int_daemon_get_verbose_flag (value unitv);
+extern void guestfs_int_daemon_exn_to_reply_with_error (const char *func, value exn);
+extern value guestfs_int_daemon_copy_mountable (const mountable_t *mountable);
+extern char **guestfs_int_daemon_return_string_list (value retv);
+extern char *guestfs_int_daemon_return_string_mountable (value retv);
+extern char **guestfs_int_daemon_return_hashtable_string_string (value retv);
+extern char **guestfs_int_daemon_return_hashtable_mountable_string (value retv);
+
+#endif /* GUESTFSD_DAEMON_C_H */
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..ddc49ed44 100644
--- a/daemon/guestfsd.c
+++ b/daemon/guestfsd.c
@@ -56,6 +56,8 @@
#include <augeas.h>
+#include <caml/callback.h> /* for caml_startup */
+
#include "sockets.h"
#include "c-ctype.h"
#include "ignore-value.h"
@@ -348,6 +350,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.
*/
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..262890952
--- /dev/null
+++ b/daemon/sysroot.ml
@@ -0,0 +1,23 @@
+(* 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 Std_utils
+
+external sysroot : unit -> string = "guestfs_int_daemon_sysroot"
+
+let sysroot_path path = sysroot () // path
diff --git a/daemon/sysroot.mli b/daemon/sysroot.mli
new file mode 100644
index 000000000..f99ab0d54
--- /dev/null
+++ b/daemon/sysroot.mli
@@ -0,0 +1,25 @@
+(* 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. *)
+
+val sysroot_path : string -> string
+(** Equivalent to calling [sysroot () // path] *)
diff --git a/daemon/utils.ml b/daemon/utils.ml
new file mode 100644
index 000000000..347ed613b
--- /dev/null
+++ b/daemon/utils.ml
@@ -0,0 +1,160 @@
+(* 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
+
+type command_flag =
+ CommandFlagFoldStdoutOnStderr
+
+let commandr ?(flags = []) prog args =
+ let fold_stdout_on_stderr = List.mem CommandFlagFoldStdoutOnStderr flags in
+
+ if verbose () then
+ eprintf "command: %s %s\n%!"
+ (if fold_stdout_on_stderr then " fold-stdout-on-stderr" else "")
+ (stringify_args (prog :: 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;
+ if not fold_stdout_on_stderr then
+ dup2 stdout_fd stdout
+ else
+ dup2 stderr_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 = String.chomp stderr in
+
+ (r, stdout, stderr)
+
+let command ?flags prog args =
+ let r, stdout, stderr = commandr ?flags 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..b399bfc00
--- /dev/null
+++ b/daemon/utils.mli
@@ -0,0 +1,72 @@
+(* 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. *)
+
+type command_flag =
+ CommandFlagFoldStdoutOnStderr
+ (** For broken external commands that send error messages to stdout
+ (hello, parted) but that don't have any useful stdout information,
+ use this flag to capture the error messages in the [stderr]
+ buffer. Nothing will be captured on stdout if you use this flag. *)
+
+val command : ?flags:command_flag list -> 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 : ?flags:command_flag list -> 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/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index a3ac13b7c..7bb6d5143 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -72,6 +72,7 @@ daemon/blkdiscard.c
daemon/blkid.c
daemon/blockdev.c
daemon/btrfs.c
+daemon/caml-stubs.c
daemon/cap.c
daemon/checksum.c
daemon/cleanups.c
@@ -82,6 +83,8 @@ daemon/compress.c
daemon/copy.c
daemon/cpio.c
daemon/cpmv.c
+daemon/daemon-c.c
+daemon/daemon-c.h
daemon/daemon.h
daemon/dd.c
daemon/debug-bmap.c
@@ -172,6 +175,7 @@ daemon/stubs.h
daemon/swap.c
daemon/sync.c
daemon/syslinux.c
+daemon/sysroot-c.c
daemon/tar.c
daemon/truncate.c
daemon/tsk.c
diff --git a/docs/guestfs-hacking.pod b/docs/guestfs-hacking.pod
index bfbe4526d..61a49e872 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.38, 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/OCaml.ml b/generator/OCaml.ml
index 53f105198..853b41bb3 100644
--- a/generator/OCaml.ml
+++ b/generator/OCaml.ml
@@ -888,3 +888,11 @@ and generate_ocaml_function_type ?(extra_unit = false) (ret, args, optargs) =
| RStructList (_, typ) -> pr "%s array" typ
| RHashtable _ -> pr "(string * string) list"
)
+
+(* Structure definitions (again). These are used in the daemon,
+ * but it's convenient to generate them here.
+ *)
+and generate_ocaml_daemon_structs () =
+ generate_header OCamlStyle GPLv2plus;
+
+ generate_ocaml_structure_decls ()
diff --git a/generator/OCaml.mli b/generator/OCaml.mli
index 4e79a5b5a..a36fbe02f 100644
--- a/generator/OCaml.mli
+++ b/generator/OCaml.mli
@@ -20,3 +20,4 @@ val generate_ocaml_c : unit -> unit
val generate_ocaml_c_errnos : unit -> unit
val generate_ocaml_ml : unit -> unit
val generate_ocaml_mli : unit -> unit
+val generate_ocaml_daemon_structs : unit -> unit
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..5004509e6 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -471,6 +471,324 @@ 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\"
+#include \"daemon-c.h\"
+
+";
+
+ (* Implement code for returning structs and struct lists. *)
+ let emit_return_struct typ =
+ let struc = Structs.lookup_struct typ in
+ pr "/* Implement RStruct (%S, _). */\n" typ;
+ pr "static guestfs_int_%s *\n" typ;
+ pr "return_%s (value retv)\n" typ;
+ pr "{\n";
+ pr " guestfs_int_%s *ret;\n" typ;
+ pr " value v;\n";
+ pr "\n";
+ pr " ret = malloc (sizeof (*ret));\n";
+ pr " if (ret == NULL) {\n";
+ pr " reply_with_perror (\"malloc\");\n";
+ pr " return NULL;\n";
+ pr " }\n";
+ pr "\n";
+ iteri (
+ fun i ->
+ pr " v = Field (retv, %d);\n" i;
+ function
+ | n, (FString|FUUID) ->
+ pr " ret->%s = strdup (String_val (v));\n" n;
+ pr " if (ret->%s == NULL) return NULL;\n" n
+ | n, FBuffer ->
+ pr " ret->%s_len = caml_string_length (v);\n" n;
+ pr " ret->%s = strdup (String_val (v));\n" n;
+ pr " if (ret->%s == NULL) return NULL;\n" n
+ | n, (FBytes|FInt64|FUInt64) ->
+ pr " ret->%s = Int64_val (v);\n" n
+ | n, (FInt32|FUInt32) ->
+ pr " ret->%s = Int32_val (v);\n" n
+ | n, FOptPercent ->
+ pr " if (v == Val_int (0)) /* None */\n";
+ pr " ret->%s = -1;\n" n;
+ pr " else {\n";
+ pr " v = Field (v, 0);\n";
+ pr " ret->%s = Double_val (v);\n" n;
+ pr " }\n"
+ | n, FChar ->
+ pr " ret->%s = Int_val (v);\n" n
+ ) struc.s_cols;
+ pr "\n";
+ pr " return ret;\n";
+ pr "}\n";
+ pr "\n"
+
+ and emit_return_struct_list typ =
+ pr "/* Implement RStructList (%S, _). */\n" typ;
+ pr "static guestfs_int_%s_list *\n" typ;
+ pr "return_%s_list (value retv)\n" typ;
+ pr "{\n";
+ pr " guestfs_int_%s_list *ret;\n" typ;
+ pr " guestfs_int_%s *r;\n" typ;
+ pr " size_t i, len;\n";
+ pr " value v, rv;\n";
+ pr "\n";
+ pr " /* Count the number of elements in the list. */\n";
+ pr " rv = retv;\n";
+ pr " len = 0;\n";
+ pr " while (rv != Val_int (0)) {\n";
+ pr " len++;\n";
+ pr " rv = Field (rv, 1);\n";
+ pr " }\n";
+ pr "\n";
+ pr " ret = malloc (sizeof *ret);\n";
+ pr " if (ret == NULL) {\n";
+ pr " reply_with_perror (\"malloc\");\n";
+ pr " return NULL;\n";
+ pr " }\n";
+ pr " ret->guestfs_int_%s_list_len = len;\n" typ;
+ pr " ret->guestfs_int_%s_list_val =\n" typ;
+ pr " calloc (len, sizeof (guestfs_int_%s));\n" typ;
+ pr " if (ret->guestfs_int_%s_list_val == NULL) {\n" typ;
+ pr " reply_with_perror (\"calloc\");\n";
+ pr " free (ret);\n";
+ pr " return NULL;\n";
+ pr " }\n";
+ pr "\n";
+ pr " rv = retv;\n";
+ pr " for (i = 0; i < len; ++i) {\n";
+ pr " v = Field (rv, 0);\n";
+ pr " r = return_%s (v);\n" typ;
+ pr " if (r == NULL)\n";
+ pr " return NULL; /* XXX leaks memory along this error path */\n";
+ pr " memcpy (&ret->guestfs_int_%s_list_val[i], r, sizeof (*r));\n" typ;
+ pr " free (r);\n";
+ pr " rv = Field (rv, 1);\n";
+ pr " }\n";
+ pr "\n";
+ pr " return ret;\n";
+ pr "}\n";
+ pr "\n";
+ in
+
+ List.iter (
+ function
+ | typ, RStructOnly ->
+ emit_return_struct typ
+ | typ, (RStructListOnly | RStructAndList) ->
+ emit_return_struct typ;
+ emit_return_struct_list typ
+ ) (rstructs_used_by (actions |> impl_ocaml_functions));
+
+ (* Implement the wrapper functions. *)
+ List.iter (
+ fun ({ name = name; style = ret, args, optargs } as f) ->
+ let uc_name = String.uppercase_ascii name in
+ 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 & GUESTFS_%s_%s_BITMASK) == 0)\n"
+ uc_name 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 ((PlainString|Device|Pathname|Dev_or_Path), n) ->
+ pr "caml_copy_string (%s)" n
+ | String ((Mountable|Mountable_or_Path), n) ->
+ pr "guestfs_int_daemon_copy_mountable (%s)" n
+ | String _ -> assert false
+ | 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 " guestfs_int_daemon_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 ->
+ pr " CAMLreturnT (int, 0);\n"
+ | RInt _ ->
+ pr " CAMLreturnT (int, Int_val (retv));\n"
+ | RInt64 _ ->
+ pr " CAMLreturnT (int, Int64_val (retv));\n"
+ | RBool _ ->
+ pr " CAMLreturnT (int, Bool_val (retv));\n"
+ | RConstString _ -> assert false
+ | RConstOptString _ -> assert false
+ | RString ((RPlainString|RDevice), _) ->
+ 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"
+ | RString (RMountable, _) ->
+ pr " char *ret =\n";
+ pr " guestfs_int_daemon_return_string_mountable (retv);\n";
+ pr " CAMLreturnT (char *, ret); /* caller frees */\n"
+ | RStringList _ ->
+ pr " char **ret = guestfs_int_daemon_return_string_list (retv);\n";
+ pr " CAMLreturnT (char **, ret); /* caller frees */\n"
+ | RStruct (_, typ) ->
+ pr " guestfs_int_%s *ret =\n" typ;
+ pr " return_%s (retv);\n" typ;
+ pr " /* caller frees */\n";
+ pr " CAMLreturnT (guestfs_int_%s *, ret);\n" typ
+ | RStructList (_, typ) ->
+ pr " guestfs_int_%s_list *ret =\n" typ;
+ pr " return_%s_list (retv);\n" typ;
+ pr " /* caller frees */\n";
+ pr " CAMLreturnT (guestfs_int_%s_list *, ret);\n" typ
+ | RHashtable (RPlainString, RPlainString, _) ->
+ pr " char **ret =\n";
+ pr " guestfs_int_daemon_return_hashtable_string_string (retv);\n";
+ pr " CAMLreturnT (char **, ret); /* caller frees */\n"
+ | RHashtable (RMountable, RPlainString, _) ->
+ pr " char **ret =\n";
+ pr " guestfs_int_daemon_return_hashtable_mountable_string (retv);\n";
+ pr " CAMLreturnT (char **, ret); /* caller frees */\n"
+ | RHashtable _ -> assert false
+ | RBufferOut _ -> assert false
+ );
+ pr "}\n";
+ pr "\n"
+ ) (actions |> impl_ocaml_functions |> sort)
+
let generate_daemon_dispatch () =
generate_header CStyle GPLv2plus;
@@ -730,6 +1048,8 @@ let generate_daemon_optgroups_c () =
pr "#include <config.h>\n";
pr "\n";
+ pr "#include <caml/mlvalues.h>\n";
+ pr "\n";
pr "#include \"daemon.h\"\n";
pr "#include \"optgroups.h\"\n";
pr "\n";
@@ -752,7 +1072,22 @@ let generate_daemon_optgroups_c () =
pr " { \"%s\", optgroup_%s_available },\n" group group
) optgroups_names_all;
pr " { NULL, NULL }\n";
- pr "};\n"
+ pr "};\n";
+ pr "\n";
+ pr "/* Wrappers so these functions can be called from OCaml code. */\n";
+ List.iter (
+ fun group ->
+ pr "extern value guestfs_int_daemon_optgroup_%s_available (value);\n"
+ group;
+ pr "\n";
+ pr "/* NB: This is a \"noalloc\" call. */\n";
+ pr "value\n";
+ pr "guestfs_int_daemon_optgroup_%s_available (value unitv)\n" group;
+ pr "{\n";
+ pr " return Val_bool (optgroup_%s_available ());\n" group;
+ pr "}\n";
+ pr "\n"
+ ) optgroups_names
let generate_daemon_optgroups_h () =
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 c8890de6a..c61326b61 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"
@@ -185,6 +191,8 @@ Run it from the top source directory using the command
OCaml.generate_ocaml_c;
output_to "ocaml/guestfs-c-errnos.c"
OCaml.generate_ocaml_c_errnos;
+ output_to "daemon/structs.ml"
+ OCaml.generate_ocaml_daemon_structs;
output_to "ocaml/bindtests.ml"
Bindtests.generate_ocaml_bindtests;
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.2
More information about the Libguestfs
mailing list