Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 00/23] Reimplement many daemon APIs in OCaml.
I think this fixes everything mentioned: - Added the Optgroups module as suggested. - Remove command temporary files. - Replace command ~flags with ?fold_stdout_on_stderr. - Nest _with_mounted function. - Rebase & retest. Rich.
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 01/23] daemon: Allow parts of the daemon and APIs to be written in OCaml.
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 | 8 +-
Makefile.am | 2 +-
common/mlutils/Makefile.am | 4 -
daemon/Makefile.am | 122 +++++++++++++---
daemon/chroot.ml | 85 +++++++++++
daemon/chroot.mli | 38 +++++
daemon/daemon-c.c | 203 ++++++++++++++++++++++++++
daemon/daemon-c.h | 38 +++++
daemon/daemon.ml | 41 ++++++
daemon/guestfsd.c | 8 ++
daemon/sysroot-c.c | 37 +++++
daemon/sysroot.ml | 23 +++
daemon/sysroot.mli | 25 ++++
daemon/utils.ml | 158 ++++++++++++++++++++
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 | 351 ++++++++++++++++++++++++++++++++++++++++++++-
generator/daemon.mli | 4 +
generator/main.ml | 10 ++
generator/types.ml | 7 +-
25 files changed, 1235 insertions(+), 30 deletions(-)
diff --git a/.gitignore b/.gitignore
index bbd9284c6..de50f7381 100644
--- a/.gitignore
+++ b/.gitignore
@@ -165,20 +165,26 @@ 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/optgroups.ml
/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..e5a4986e3 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,71 @@ 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 \
+ optgroups.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 +323,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..bf486344f
--- /dev/null
+++ b/daemon/daemon.ml
@@ -0,0 +1,41 @@
+(* 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, early on (after parsing the command line
+ * but not much else), 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 8489500c6..90fc1058a 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"
@@ -231,6 +233,12 @@ main (int argc, char *argv[])
exit (EXIT_FAILURE);
}
+ /* Initialize the OCaml stubs. This must be done after the
+ * ‘verbose’ flag is set from the command line since the OCaml
+ * initialization code depends on that.
+ */
+ caml_startup (argv);
+
#ifndef WIN32
/* Make sure SIGPIPE doesn't kill us. */
struct sigaction sa;
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..f2c1ea328
--- /dev/null
+++ b/daemon/utils.ml
@@ -0,0 +1,158 @@
+(* 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 ?(fold_stdout_on_stderr = false) prog args + 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
+
+ (try unlink stdout_file with _ -> ());
+ (try unlink stderr_file with _ -> ());
+
+ 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 ?fold_stdout_on_stderr prog args + let r, stdout, stderr =
commandr ?fold_stdout_on_stderr 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..b475ae3b8
--- /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. *)
+
+val command : ?fold_stdout_on_stderr:bool -> 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.
+
+ [?fold_stdout_on_stderr] (default: false)
+
+ 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 commandr : ?fold_stdout_on_stderr:bool -> 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..b4d4cfe8e 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;
@@ -801,8 +1136,18 @@ let generate_daemon_optgroups_h ()
pr "#endif /* GUESTFSD_OPTGROUPS_H */\n"
+(* Generate optgroup available functions in OCaml. *)
+let generate_daemon_optgroups_ml () + generate_header OCamlStyle GPLv2plus;
+
+ List.iter (
+ fun group ->
+ pr "external %s_available : unit -> bool =\n" group;
+ pr " \"guestfs_int_daemon_optgroup_%s_available\"
\"noalloc\"\n" group
+ ) optgroups_names
+
(* Generate structs-cleanups.c file. *)
-and generate_daemon_structs_cleanups_c () +let
generate_daemon_structs_cleanups_c () generate_header CStyle GPLv2plus;
pr "\
@@ -852,7 +1197,7 @@ and generate_daemon_structs_cleanups_c () ) structs
(* Generate structs-cleanups.h file. *)
-and generate_daemon_structs_cleanups_h () +let
generate_daemon_structs_cleanups_h () generate_header CStyle GPLv2plus;
pr "\
diff --git a/generator/daemon.mli b/generator/daemon.mli
index ff008bf85..602f36a86 100644
--- a/generator/daemon.mli
+++ b/generator/daemon.mli
@@ -19,10 +19,14 @@
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
val generate_daemon_optgroups_c : unit -> unit
val generate_daemon_optgroups_h : unit -> unit
+val generate_daemon_optgroups_ml : unit -> unit
val generate_daemon_structs_cleanups_c : unit -> unit
val generate_daemon_structs_cleanups_h : unit -> unit
diff --git a/generator/main.ml b/generator/main.ml
index c8890de6a..9d795b15a 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"
@@ -141,6 +147,8 @@ Run it from the top source directory using the command
Daemon.generate_daemon_optgroups_c;
output_to "daemon/optgroups.h"
Daemon.generate_daemon_optgroups_h;
+ output_to "daemon/optgroups.ml"
+ Daemon.generate_daemon_optgroups_ml;
output_to "daemon/lvm-tokenization.c"
Daemon.generate_daemon_lvm_tokenization;
output_to "daemon/structs-cleanups.c"
@@ -185,6 +193,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
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 02/23] daemon: Reimplement ‘file’ API in OCaml.
‘file’ is a small, self-contained API which runs a single command, so
it's a good test case for reimplementing APIs.
---
daemon/Makefile.am | 2 ++
daemon/file.c | 79 -----------------------------------------------
daemon/file.ml | 59 +++++++++++++++++++++++++++++++++++
daemon/file.mli | 19 ++++++++++++
generator/actions_core.ml | 1 +
5 files changed, 81 insertions(+), 79 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index e5a4986e3..8cf5d77ce 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -243,6 +243,7 @@ guestfsd_CFLAGS = \
SOURCES_MLI = \
chroot.mli \
sysroot.mli \
+ file.mli \
utils.mli
SOURCES_ML = \
@@ -252,6 +253,7 @@ SOURCES_ML = \
optgroups.ml \
sysroot.ml \
chroot.ml \
+ file.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/file.c b/daemon/file.c
index da4218c45..2d687a960 100644
--- a/daemon/file.c
+++ b/daemon/file.c
@@ -445,85 +445,6 @@ do_pwrite_device (const char *device, const char *content,
size_t size,
return pwrite_fd (fd, content, size, offset, device, 1);
}
-/* This runs the 'file' command. */
-char *
-do_file (const char *path)
-{
- CLEANUP_FREE char *buf = NULL;
- const char *display_path = path;
- const int is_dev = STRPREFIX (path, "/dev/");
- struct stat statbuf;
-
- if (!is_dev) {
- buf = sysroot_path (path);
- if (!buf) {
- reply_with_perror ("malloc");
- return NULL;
- }
- path = buf;
-
- /* For non-dev, check this is a regular file, else just return the
- * file type as a string (RHBZ#582484).
- */
- if (lstat (path, &statbuf) == -1) {
- reply_with_perror ("lstat: %s", display_path);
- return NULL;
- }
-
- if (! S_ISREG (statbuf.st_mode)) {
- char *ret;
-
- if (S_ISDIR (statbuf.st_mode))
- ret = strdup ("directory");
- else if (S_ISCHR (statbuf.st_mode))
- ret = strdup ("character device");
- else if (S_ISBLK (statbuf.st_mode))
- ret = strdup ("block device");
- else if (S_ISFIFO (statbuf.st_mode))
- ret = strdup ("FIFO");
- else if (S_ISLNK (statbuf.st_mode))
- ret = strdup ("symbolic link");
- else if (S_ISSOCK (statbuf.st_mode))
- ret = strdup ("socket");
- else
- ret = strdup ("unknown, not regular file");
-
- if (ret == NULL)
- reply_with_perror ("strdup");
- return ret;
- }
- }
-
- /* Which flags to use? For /dev paths, follow links because
- * /dev/VG/LV is a symbolic link.
- */
- const char *flags = is_dev ? "-zbsL" : "-zb";
-
- char *out;
- CLEANUP_FREE char *err = NULL;
- int r = command (&out, &err, "file", flags, path, NULL);
-
- if (r == -1) {
- free (out);
- reply_with_error ("%s: %s", display_path, err);
- return NULL;
- }
-
- /* We need to remove the trailing \n from output of file(1). */
- size_t len = strlen (out);
- if (len > 0 && out[len-1] == '\n')
- out[--len] = '\0';
-
- /* Some upstream versions of file add a space at the end of the
- * output. This is fixed in the Fedora version, but we might as
- * well fix it here too. (RHBZ#928995).
- */
- if (len > 0 && out[len-1] == ' ')
- out[--len] = '\0';
-
- return out; /* caller frees */
-}
-
/* zcat | file */
char *
do_zfile (const char *method, const char *path)
diff --git a/daemon/file.ml b/daemon/file.ml
new file mode 100644
index 000000000..b45bd9019
--- /dev/null
+++ b/daemon/file.ml
@@ -0,0 +1,59 @@
+(* 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
+
+open Utils
+
+(* This runs the [file] command. *)
+let file path + let is_dev = String.is_prefix path "/dev/" in
+
+ (* For non-dev, check this is a regular file, else just return the
+ * file type as a string (RHBZ#582484).
+ *)
+ if not is_dev then (
+ let chroot = Chroot.create ~name:(sprintf "file: %s" path) () in
+
+ let statbuf = Chroot.f chroot lstat path in
+ match statbuf.st_kind with
+ | S_DIR -> "directory"
+ | S_CHR -> "character device"
+ | S_BLK -> "block device"
+ | S_FIFO -> "FIFO"
+ | S_LNK -> "symbolic link"
+ | S_SOCK -> "socket"
+ | S_REG ->
+ (* Regular file, so now run [file] on it. *)
+ let out = command "file" ["-zb";
Sysroot.sysroot_path path] in
+
+ (* We need to remove the trailing \n from output of file(1).
+ *
+ * Some upstream versions of file add a space at the end of the
+ * output. This is fixed in the Fedora version, but we might as
+ * well fix it here too. (RHBZ#928995).
+ *)
+ String.trimr out
+ )
+ else (* it's a device *) (
+ let out = command "file" ["-zbsL"; path] in
+ String.trimr out
+ )
diff --git a/daemon/file.mli b/daemon/file.mli
new file mode 100644
index 000000000..bd49bad0b
--- /dev/null
+++ b/daemon/file.mli
@@ -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.
+ *)
+
+val file : string -> string
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 0e667eff1..26ed1274e 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -2321,6 +2321,7 @@ and physical volumes." };
{ defaults with
name = "file"; added = (1, 9, 1);
style = RString (RPlainString, "description"), [String
(Dev_or_Path, "path")], [];
+ impl = OCaml "File.file";
tests = [
InitISOFS, Always, TestResultString (
[["file"; "/empty"]], "empty"), [];
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 03/23] daemon: Reimplement ‘vfs_type’ API in OCaml.
---
daemon/Makefile.am | 4 ++++
daemon/blkid.c | 6 ------
daemon/blkid.ml | 40 ++++++++++++++++++++++++++++++++++++++++
daemon/blkid.mli | 19 +++++++++++++++++++
daemon/mountable.ml | 43 +++++++++++++++++++++++++++++++++++++++++++
daemon/mountable.mli | 34 ++++++++++++++++++++++++++++++++++
generator/actions_core.ml | 1 +
7 files changed, 141 insertions(+), 6 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 8cf5d77ce..cf0e2c503 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -241,9 +241,11 @@ guestfsd_CFLAGS = \
# library and then linked to the daemon. See
# https://caml.inria.fr/pub/docs/manual-ocaml/intfc.html
SOURCES_MLI = \
+ blkid.mli \
chroot.mli \
sysroot.mli \
file.mli \
+ mountable.mli \
utils.mli
SOURCES_ML = \
@@ -252,7 +254,9 @@ SOURCES_ML = \
structs.ml \
optgroups.ml \
sysroot.ml \
+ mountable.ml \
chroot.ml \
+ blkid.ml \
file.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/blkid.c b/daemon/blkid.c
index d9858d5c8..fea322f5e 100644
--- a/daemon/blkid.c
+++ b/daemon/blkid.c
@@ -67,12 +67,6 @@ get_blkid_tag (const char *device, const char *tag)
}
char *
-do_vfs_type (const mountable_t *mountable)
-{
- return get_blkid_tag (mountable->device, "TYPE");
-}
-
-char *
do_vfs_label (const mountable_t *mountable)
{
CLEANUP_FREE char *type = do_vfs_type (mountable);
diff --git a/daemon/blkid.ml b/daemon/blkid.ml
new file mode 100644
index 000000000..69baa8e8d
--- /dev/null
+++ b/daemon/blkid.ml
@@ -0,0 +1,40 @@
+(* 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
+
+open Utils
+
+let rec vfs_type { Mountable.m_device = device } + get_blkid_tag device
"TYPE"
+
+and get_blkid_tag device tag + let r, out, err + commandr "blkid"
+ [(* Adding -c option kills all caching, even on RHEL 5. *)
+ "-c"; "/dev/null";
+ "-o"; "value"; "-s"; tag; device]
in
+ match r with
+ | 0 -> (* success *)
+ String.chomp out
+
+ | 2 -> (* means tag not found, we return
"" *)
+ ""
+
+ | _ ->
+ failwithf "blkid: %s: %s: %s" device tag err
diff --git a/daemon/blkid.mli b/daemon/blkid.mli
new file mode 100644
index 000000000..59a86ac2c
--- /dev/null
+++ b/daemon/blkid.mli
@@ -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.
+ *)
+
+val vfs_type : Mountable.t -> string
diff --git a/daemon/mountable.ml b/daemon/mountable.ml
new file mode 100644
index 000000000..96dffb80b
--- /dev/null
+++ b/daemon/mountable.ml
@@ -0,0 +1,43 @@
+(* 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
+
+type t = {
+ m_type : mountable_type;
+ m_device : string;
+}
+and mountable_type + | MountableDevice
+ | MountablePath
+ | MountableBtrfsVol of string (* volume *)
+
+let to_string { m_type = t; m_device = device } + match t with
+ | MountableDevice | MountablePath -> device
+ | MountableBtrfsVol volume ->
+ sprintf "btrfsvol:%s/%s" device volume
+
+let of_device device + { m_type = MountableDevice; m_device = device }
+
+let of_path path + { m_type = MountablePath; m_device = path }
+
+let of_btrfsvol device volume + { m_type = MountableBtrfsVol volume; m_device
= device }
diff --git a/daemon/mountable.mli b/daemon/mountable.mli
new file mode 100644
index 000000000..52f1ad45b
--- /dev/null
+++ b/daemon/mountable.mli
@@ -0,0 +1,34 @@
+(* 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.
+ *)
+
+type t = {
+ m_type : mountable_type;
+ m_device : string;
+}
+and mountable_type + | MountableDevice
+ | MountablePath
+ | MountableBtrfsVol of string (* volume *)
+
+val to_string : t -> string
+(** Convert the mountable back to the string used in the public API. *)
+
+val of_device : string -> t
+val of_path : string -> t
+val of_btrfsvol : string -> string -> t
+(** Create a mountable from various objects. *)
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 26ed1274e..a6eb2c273 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -4872,6 +4872,7 @@ See also C<guestfs_realpath>." };
{ defaults with
name = "vfs_type"; added = (1, 0, 75);
style = RString (RPlainString, "fstype"), [String (Mountable,
"mountable")], [];
+ impl = OCaml "Blkid.vfs_type";
tests = [
InitScratchFS, Always, TestResultString (
[["vfs_type"; "/dev/sdb1"]], "ext2"), []
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 04/23] daemon: Reimplement several devsparts APIs in OCaml.
The reimplemented APIs are:
* list_devices
* list_partitions
* part_to_dev
* part_to_partnum
* is_whole_device
---
daemon/Makefile.am | 2 +
daemon/daemon.h | 2 -
daemon/devsparts.c | 257 ----------------------------------------------
daemon/devsparts.ml | 113 ++++++++++++++++++++
daemon/devsparts.mli | 25 +++++
daemon/guestfsd.c | 75 --------------
daemon/utils.ml | 84 +++++++++++++++
daemon/utils.mli | 15 +++
generator/actions_core.ml | 5 +
9 files changed, 244 insertions(+), 334 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index cf0e2c503..2cdf20c07 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -244,6 +244,7 @@ SOURCES_MLI = \
blkid.mli \
chroot.mli \
sysroot.mli \
+ devsparts.mli \
file.mli \
mountable.mli \
utils.mli
@@ -257,6 +258,7 @@ SOURCES_ML = \
mountable.ml \
chroot.ml \
blkid.ml \
+ devsparts.ml \
file.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/daemon.h b/daemon/daemon.h
index a68a79e12..4acc9c9fe 100644
--- a/daemon/daemon.h
+++ b/daemon/daemon.h
@@ -67,8 +67,6 @@ extern int xread (int sock, void *buf, size_t len)
__attribute__((__warn_unused_result__));
extern void sort_strings (char **argv, size_t len);
extern void free_stringslen (char **argv, size_t len);
-extern void sort_device_names (char **argv, size_t len);
-extern int compare_device_names (const char *a, const char *b);
extern char **take_stringsbuf (struct stringsbuf *sb);
extern void free_stringsbuf (struct stringsbuf *sb);
extern struct stringsbuf split_lines_sb (char *str);
diff --git a/daemon/devsparts.c b/daemon/devsparts.c
index 82467b92f..1aacb8e16 100644
--- a/daemon/devsparts.c
+++ b/daemon/devsparts.c
@@ -33,263 +33,6 @@
#include "daemon.h"
#include "actions.h"
-typedef int (*block_dev_func_t) (const char *dev, struct stringsbuf *r);
-
-/* Execute a given function for each discovered block device */
-static char **
-foreach_block_device (block_dev_func_t func, bool return_md)
-{
- CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (r);
- DIR *dir;
- int err = 0;
- struct dirent *d;
- int fd;
-
- dir = opendir ("/sys/block");
- if (!dir) {
- reply_with_perror ("opendir: /sys/block");
- return NULL;
- }
-
- for (;;) {
- errno = 0;
- d = readdir (dir);
- if (!d) break;
-
- if (STREQLEN (d->d_name, "sd", 2) ||
- STREQLEN (d->d_name, "hd", 2) ||
- STREQLEN (d->d_name, "ubd", 3) ||
- STREQLEN (d->d_name, "vd", 2) ||
- STREQLEN (d->d_name, "sr", 2) ||
- (return_md &&
- STREQLEN (d->d_name, "md", 2) && c_isdigit
(d->d_name[2]))) {
- CLEANUP_FREE char *dev_path = NULL;
- if (asprintf (&dev_path, "/dev/%s", d->d_name) == -1) {
- reply_with_perror ("asprintf");
- closedir (dir);
- return NULL;
- }
-
- /* Ignore the root device. */
- if (is_root_device (dev_path))
- continue;
-
- /* RHBZ#514505: Some versions of qemu <= 0.10 add a
- * CD-ROM device even though we didn't request it. Try to
- * detect this by seeing if the device contains media.
- */
- fd = open (dev_path, O_RDONLY|O_CLOEXEC);
- if (fd == -1) {
- perror (dev_path);
- continue;
- }
- close (fd);
-
- /* Call the map function for this device */
- if ((*func)(d->d_name, &r) != 0) {
- err = 1;
- break;
- }
- }
- }
-
- /* Check readdir didn't fail */
- if (errno != 0) {
- reply_with_perror ("readdir: /sys/block");
- closedir (dir);
- return NULL;
- }
-
- /* Close the directory handle */
- if (closedir (dir) == -1) {
- reply_with_perror ("closedir: /sys/block");
- return NULL;
- }
-
- if (err)
- return NULL;
-
- /* Sort the devices. */
- if (r.size > 0)
- sort_device_names (r.argv, r.size);
-
- /* NULL terminate the list */
- if (end_stringsbuf (&r) == -1) {
- return NULL;
- }
-
- return take_stringsbuf (&r);
-}
-
-/* Add a device to the list of devices */
-static int
-add_device (const char *device, struct stringsbuf *r)
-{
- char *dev_path;
-
- if (asprintf (&dev_path, "/dev/%s", device) == -1) {
- reply_with_perror ("asprintf");
- return -1;
- }
-
- if (add_string_nodup (r, dev_path) == -1)
- return -1;
-
- return 0;
-}
-
-char **
-do_list_devices (void)
-{
- /* For backwards compatibility, don't return MD devices in the list
- * returned by guestfs_list_devices. This is because most API users
- * expect that this list is effectively the same as the list of
- * devices added by guestfs_add_drive.
- *
- * Also, MD devices are special devices - unlike the devices exposed
- * by QEMU, and there is a special API for them,
- * guestfs_list_md_devices.
- */
- return foreach_block_device (add_device, false);
-}
-
-static int
-add_partitions (const char *device, struct stringsbuf *r)
-{
- CLEANUP_FREE char *devdir = NULL;
-
- /* Open the device's directory under /sys/block */
- if (asprintf (&devdir, "/sys/block/%s", device) == -1) {
- reply_with_perror ("asprintf");
- return -1;
- }
-
- DIR *dir = opendir (devdir);
- if (!dir) {
- reply_with_perror ("opendir: %s", devdir);
- return -1;
- }
-
- /* Look in /sys/block/<device>/ for entries starting with
<device>
- * e.g. /sys/block/sda/sda1
- */
- errno = 0;
- struct dirent *d;
- while ((d = readdir (dir)) != NULL) {
- if (STREQLEN (d->d_name, device, strlen (device))) {
- CLEANUP_FREE char *part = NULL;
- if (asprintf (&part, "/dev/%s", d->d_name) == -1) {
- perror ("asprintf");
- closedir (dir);
- return -1;
- }
-
- if (add_string (r, part) == -1) {
- closedir (dir);
- return -1;
- }
- }
- }
-
- /* Check if readdir failed */
- if (0 != errno) {
- reply_with_perror ("readdir: %s", devdir);
- closedir (dir);
- return -1;
- }
-
- /* Close the directory handle */
- if (closedir (dir) == -1) {
- reply_with_perror ("closedir: /sys/block/%s", device);
- return -1;
- }
-
- return 0;
-}
-
-char **
-do_list_partitions (void)
-{
- return foreach_block_device (add_partitions, true);
-}
-
-char *
-do_part_to_dev (const char *part)
-{
- int err = 1;
- size_t n = strlen (part);
-
- while (n >= 1 && c_isdigit (part[n-1])) {
- err = 0;
- n--;
- }
-
- if (err) {
- reply_with_error ("device name is not a partition");
- return NULL;
- }
-
- /* Deal with <device>p<N> partition names such as /dev/md0p1. */
- if (part[n-1] == 'p')
- n--;
-
- char *r = strndup (part, n);
- if (r == NULL) {
- reply_with_perror ("strdup");
- return NULL;
- }
-
- return r;
-}
-
-int
-do_part_to_partnum (const char *part)
-{
- int err = 1;
- size_t n = strlen (part);
-
- while (n >= 1 && c_isdigit (part[n-1])) {
- err = 0;
- n--;
- }
-
- if (err) {
- reply_with_error ("device name is not a partition");
- return -1;
- }
-
- int r;
- if (sscanf (&part[n], "%d", &r) != 1) {
- reply_with_error ("could not parse number");
- return -1;
- }
-
- return r;
-}
-
-int
-do_is_whole_device (const char *device)
-{
- /* A 'whole' block device will have a symlink to the device in its
- * /sys/block directory */
- CLEANUP_FREE char *devpath = NULL;
- if (asprintf (&devpath, "/sys/block/%s/device",
- device + strlen ("/dev/")) == -1) {
- reply_with_perror ("asprintf");
- return -1;
- }
-
- struct stat statbuf;
- if (stat (devpath, &statbuf) == -1) {
- if (errno == ENOENT || errno == ENOTDIR) return 0;
-
- reply_with_perror ("stat");
- return -1;
- }
-
- return 1;
-}
-
int
do_device_index (const char *device)
{
diff --git a/daemon/devsparts.ml b/daemon/devsparts.ml
new file mode 100644
index 000000000..43093aba8
--- /dev/null
+++ b/daemon/devsparts.ml
@@ -0,0 +1,113 @@
+(* 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 Utils
+
+let map_block_devices ~return_md f + let devs = Sys.readdir
"/sys/block" in
+ let devs = Array.to_list devs in
+ let devs = List.filter (
+ fun dev ->
+ String.is_prefix dev "sd" ||
+ String.is_prefix dev "hd" ||
+ String.is_prefix dev "ubd" ||
+ String.is_prefix dev "vd" ||
+ String.is_prefix dev "sr" ||
+ (return_md && String.is_prefix dev "md" &&
+ String.length dev >= 3 && Char.isdigit dev.[2])
+ ) devs in
+
+ (* Ignore the root device. *)
+ let devs + List.filter (fun dev -> not (is_root_device
("/dev/" ^ dev))) devs in
+
+ (* RHBZ#514505: Some versions of qemu <= 0.10 add a
+ * CD-ROM device even though we didn't request it. Try to
+ * detect this by seeing if the device contains media.
+ *)
+ let devs + List.filter (
+ fun dev ->
+ try
+ let fd = openfile ("/dev/" ^ dev) [O_RDONLY] 0 in
+ Unix.set_close_on_exec fd; (* XXX *)
+ close fd;
+ true
+ with _ -> false
+ ) devs in
+
+ (* Call the map function for the devices left in the list. *)
+ List.map f devs
+
+let list_devices () + (* For backwards compatibility, don't return MD
devices in the list
+ * returned by guestfs_list_devices. This is because most API users
+ * expect that this list is effectively the same as the list of
+ * devices added by guestfs_add_drive.
+ *
+ * Also, MD devices are special devices - unlike the devices exposed
+ * by QEMU, and there is a special API for them,
+ * guestfs_list_md_devices.
+ *)
+ let devices + map_block_devices ~return_md:false ((^) "/dev/")
in
+ sort_device_names devices
+
+let rec list_partitions () + let partitions = map_block_devices
~return_md:true add_partitions in
+ let partitions = List.flatten partitions in
+ sort_device_names partitions
+
+and add_partitions dev + (* Open the device's directory under /sys/block
*)
+ let parts = Sys.readdir ("/sys/block/" ^ dev) in
+ let parts = Array.to_list parts in
+
+ (* Look in /sys/block/<device>/ for entries starting with
+ * <device>, eg. /sys/block/sda/sda1.
+ *)
+ let parts = List.filter (fun part -> String.is_prefix part dev) parts in
+ List.map ((^) "/dev/") parts
+
+let part_to_dev part + let dev, part = split_device_partition part in
+ if part = 0 then
+ failwithf "device name is not a partition";
+ "/dev/" ^ dev
+
+let part_to_partnum part + let _, part = split_device_partition part in
+ if part = 0 then
+ failwithf "device name is not a partition";
+ part
+
+let is_whole_device device + (* A 'whole' block device will have a
symlink to the device in its
+ * /sys/block directory
+ *)
+ assert (String.is_prefix device "/dev/");
+ let device = String.sub device 5 (String.length device - 5) in
+ let devpath = sprintf "/sys/block/%s/device" device in
+
+ try ignore (stat devpath); true
+ with Unix_error ((ENOENT|ENOTDIR), _, _) -> false
diff --git a/daemon/devsparts.mli b/daemon/devsparts.mli
new file mode 100644
index 000000000..4dfaa86e6
--- /dev/null
+++ b/daemon/devsparts.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 list_devices : unit -> string list
+val list_partitions : unit -> string list
+
+val part_to_dev : string -> string
+val part_to_partnum : string -> int
+
+val is_whole_device : string -> bool
diff --git a/daemon/guestfsd.c b/daemon/guestfsd.c
index 90fc1058a..2ceaccbee 100644
--- a/daemon/guestfsd.c
+++ b/daemon/guestfsd.c
@@ -628,81 +628,6 @@ free_stringslen (char **argv, size_t len)
}
/**
- * Compare device names (including partition numbers if present).
- *
- *
L<https://rwmj.wordpress.com/2011/01/09/how-are-linux-drives-named-beyond-drive-26-devsdz/>
- */
-int
-compare_device_names (const char *a, const char *b)
-{
- size_t alen, blen;
- int r;
- int a_partnum, b_partnum;
-
- /* Skip /dev/ prefix if present. */
- if (STRPREFIX (a, "/dev/"))
- a += 5;
- if (STRPREFIX (b, "/dev/"))
- b += 5;
-
- /* Skip sd/hd/ubd/vd. */
- alen = strcspn (a, "d");
- blen = strcspn (b, "d");
- assert (alen > 0 && alen <= 2);
- assert (blen > 0 && blen <= 2);
- a += alen + 1;
- b += blen + 1;
-
- /* Get device name part, that is, just 'a', 'ab' etc. */
- alen = strcspn (a, "0123456789");
- blen = strcspn (b, "0123456789");
-
- /* If device name part is longer, it is always greater, eg.
- * "/dev/sdz" < "/dev/sdaa".
- */
- if (alen != blen)
- return alen - blen;
-
- /* Device name parts are the same length, so do a regular compare. */
- r = strncmp (a, b, alen);
- if (r != 0)
- return r;
-
- /* Compare partitions numbers. */
- a += alen;
- b += alen;
-
- /* If no partition numbers, bail -- the devices are the same. This
- * can happen in one peculiar case: where you have a mix of devices
- * with different interfaces (eg. /dev/sda and /dev/vda).
- * (RHBZ#858128).
- */
- if (!*a && !*b)
- return 0;
-
- r = sscanf (a, "%d", &a_partnum);
- assert (r == 1);
- r = sscanf (b, "%d", &b_partnum);
- assert (r == 1);
-
- return a_partnum - b_partnum;
-}
-
-static int
-compare_device_names_vp (const void *vp1, const void *vp2)
-{
- char * const *p1 = (char * const *) vp1;
- char * const *p2 = (char * const *) vp2;
- return compare_device_names (*p1, *p2);
-}
-
-void
-sort_device_names (char **argv, size_t len)
-{
- qsort (argv, len, sizeof (char *), compare_device_names_vp);
-}
-
-/**
* Split an output string into a NULL-terminated list of lines,
* wrapped into a stringsbuf.
*
diff --git a/daemon/utils.ml b/daemon/utils.ml
index f2c1ea328..b459a2314 100644
--- a/daemon/utils.ml
+++ b/daemon/utils.ml
@@ -131,6 +131,90 @@ let is_root_device device device func arg
(error_message err);
false
+(* XXX This function is copied from C, but is misconceived. It
+ * cannot by design work for devices like /dev/md0. It would be
+ * better if it checked for the existence of devices and partitions
+ * in /sys/block so we know what the kernel thinks is a device or
+ * partition. The same applies to APIs such as part_to_partnum
+ * and part_to_dev which rely on this function.
+ *)
+let split_device_partition dev + (* Skip /dev/ prefix if present. *)
+ let dev + if String.is_prefix dev "/dev/" then
+ String.sub dev 5 (String.length dev - 5)
+ else dev in
+
+ (* Find the partition number (if present). *)
+ let dev, part + let n = String.length dev in
+ let i = ref n in
+ while !i >= 1 && Char.isdigit dev.[!i-1] do
+ decr i
+ done;
+ let i = !i in
+ if i = n then
+ dev, 0 (* no partition number, whole device *)
+ else
+ String.sub dev 0 i, int_of_string (String.sub dev i (n-i)) in
+
+ (* Deal with device names like /dev/md0p1. *)
+ (* XXX This function is buggy (as was the old C function) when
+ * presented with a whole device like /dev/md0.
+ *)
+ let dev + let n = String.length dev in
+ if n < 2 || dev.[n-1] <> 'p' || not (Char.isdigit
dev.[n-2]) then
+ dev
+ else (
+ let i = ref (n-1) in
+ while !i >= 0 && Char.isdigit dev.[!i] do
+ decr i;
+ done;
+ let i = !i in
+ String.sub dev 0 i
+ ) in
+
+ dev, part
+
+let rec sort_device_names devs + List.sort compare_device_names devs
+
+and compare_device_names a b + (* This takes the device name like
"/dev/sda1" and returns ("sda", 1). *)
+ let dev_a, part_a = split_device_partition a
+ and dev_b, part_b = split_device_partition b in
+
+ (* Skip "sd|hd|ubd..." so that /dev/sda and /dev/vda sort together.
+ * (This is what the old C function did, but it's not clear if it
+ * is still relevant. XXX)
+ *)
+ let skip_prefix dev + let n = String.length dev in
+ if n >= 2 && dev.[1] = 'd' then
+ String.sub dev 2 (String.length dev - 2)
+ else if n >= 3 && dev.[2] = 'd' then
+ String.sub dev 3 (String.length dev - 3)
+ else
+ dev in
+ let dev_a = skip_prefix dev_a
+ and dev_b = skip_prefix dev_b in
+
+ (* If device name part is longer, it is always greater, eg.
+ * "/dev/sdz" < "/dev/sdaa".
+ *)
+ let r = compare (String.length dev_a) (String.length dev_b) in
+ if r <> 0 then r
+ else (
+ (* Device name parts are the same length, so do a regular compare. *)
+ let r = compare dev_a dev_b in
+ if r <> 0 then r
+ else (
+ (* Device names are identical, so compare partition numbers. *)
+ compare part_a part_b
+ )
+ )
+
let proc_unmangle_path path let n = String.length path in
let b = Buffer.create n in
diff --git a/daemon/utils.mli b/daemon/utils.mli
index b475ae3b8..16569f018 100644
--- a/daemon/utils.mli
+++ b/daemon/utils.mli
@@ -41,6 +41,21 @@ val is_root_device_stat : Unix.stats -> bool
(** As for {!is_root_device} but operates on a statbuf instead of
a device name. *)
+val split_device_partition : string -> string * int
+(** Split a device name like [/dev/sda1] into a device name and
+ partition number, eg. ["sda", 1].
+
+ The [/dev/] prefix is skipped and removed, if present.
+
+ If the partition number is not present (a whole device), 0 is returned.
+
+ This function splits [/dev/md0p1] to ["md0", 1]. *)
+
+val sort_device_names : string list -> string list
+(** Sort device names correctly so that /dev/sdaa appears after /dev/sdz.
+ This also deals with partition numbers, and works whether or not
+ [/dev/] is present. *)
+
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. *)
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index a6eb2c273..94391288f 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -1817,6 +1817,7 @@ is I<not> intended that you try to parse the output
string." };
{ defaults with
name = "list_devices"; added = (0, 0, 4);
style = RStringList (RDevice, "devices"), [], [];
+ impl = OCaml "Devsparts.list_devices";
tests = [
InitEmpty, Always, TestResult (
[["list_devices"]],
@@ -1833,6 +1834,7 @@ See also C<guestfs_list_filesystems>." };
{ defaults with
name = "list_partitions"; added = (0, 0, 4);
style = RStringList (RDevice, "partitions"), [], [];
+ impl = OCaml "Devsparts.list_partitions";
tests = [
InitBasicFS, Always, TestResult (
[["list_partitions"]],
@@ -6086,6 +6088,7 @@ See also C<guestfs_stat>." };
{ defaults with
name = "part_to_dev"; added = (1, 5, 15);
style = RString (RDevice, "device"), [String (Device,
"partition")], [];
+ impl = OCaml "Devsparts.part_to_dev";
tests = [
InitPartition, Always, TestResultDevice (
[["part_to_dev"; "/dev/sda1"]],
"/dev/sda"), [];
@@ -6533,6 +6536,7 @@ as in C<guestfs_compress_out>." };
{ defaults with
name = "part_to_partnum"; added = (1, 13, 25);
style = RInt "partnum", [String (Device, "partition")],
[];
+ impl = OCaml "Devsparts.part_to_partnum";
tests = [
InitPartition, Always, TestResult (
[["part_to_partnum"; "/dev/sda1"]], "ret ==
1"), [];
@@ -8480,6 +8484,7 @@ you are better to use C<guestfs_mv> instead."
};
{ defaults with
name = "is_whole_device"; added = (1, 21, 9);
style = RBool "flag", [String (Device, "device")], [];
+ impl = OCaml "Devsparts.is_whole_device";
tests = [
InitEmpty, Always, TestResultTrue (
[["is_whole_device"; "/dev/sda"]]), [];
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 05/23] daemon: Add unit tests of the ‘Utils’ module.
---
.gitignore | 1 +
daemon/Makefile.am | 45 ++++++++++++++++++++++++++++++++++++++++-
daemon/daemon_utils_tests.ml | 48 ++++++++++++++++++++++++++++++++++++++++++++
daemon/dummy.c | 2 ++
docs/C_SOURCE_FILES | 1 +
5 files changed, 96 insertions(+), 1 deletion(-)
diff --git a/.gitignore b/.gitignore
index de50f7381..4699933d3 100644
--- a/.gitignore
+++ b/.gitignore
@@ -169,6 +169,7 @@ Makefile.in
/daemon/actions.h
/daemon/callbacks.ml
/daemon/caml-stubs.c
+/daemon/daemon_utils_tests
/daemon/dispatch.c
/daemon/guestfsd
/daemon/guestfsd.8
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 2cdf20c07..f1b395725 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -42,6 +42,7 @@ generator_built = \
EXTRA_DIST = \
$(generator_built) \
$(SOURCES_MLI) $(SOURCES_ML) \
+ daemon_utils_tests.ml \
guestfsd.pod
if INSTALL_DAEMON
@@ -269,7 +270,8 @@ XOBJECTS = $(BOBJECTS:.cmo=.cmx)
OCAMLPACKAGES = \
-package str,unix,hivex \
-I $(top_srcdir)/common/mlstdutils \
- -I $(top_srcdir)/common/mlutils
+ -I $(top_srcdir)/common/mlutils \
+ -I $(top_builddir)/common/utils/.libs
OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_FLAGS)
@@ -310,6 +312,47 @@ depend: .depend
-include .depend
+# Tests.
+
+check_PROGRAMS = daemon_utils_tests
+TESTS_ENVIRONMENT = $(top_builddir)/run --test
+TESTS = \
+ daemon_utils_tests
+
+check-valgrind:
+ $(MAKE) VG="@VG@" check
+
+daemon_utils_tests_SOURCES = dummy.c
+daemon_utils_tests_CPPFLAGS = \
+ -I. \
+ -I$(top_builddir) \
+ -I$(shell $(OCAMLC) -where) \
+ -I$(top_srcdir)/lib
+daemon_utils_tests_BOBJECTS = \
+ utils.cmo \
+ daemon_utils_tests.cmo
+daemon_utils_tests_XOBJECTS = $(daemon_utils_tests_BOBJECTS:.cmo=.cmx)
+
+if !HAVE_OCAMLOPT
+daemon_utils_tests_THEOBJECTS = $(daemon_utils_tests_BOBJECTS)
+else
+daemon_utils_tests_THEOBJECTS = $(daemon_utils_tests_XOBJECTS)
+endif
+
+OCAMLLINKFLAGS = \
+ mlcutils.$(MLARCHIVE) \
+ mlstdutils.$(MLARCHIVE) \
+ $(LINK_CUSTOM_OCAMLC_ONLY)
+
+daemon_utils_tests_DEPENDENCIES = \
+ $(daemon_utils_tests_THEOBJECTS) \
+ $(top_srcdir)/ocaml-link.sh
+daemon_utils_tests_LINK = \
+ $(top_srcdir)/ocaml-link.sh -- \
+ $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLLINKFLAGS) \
+ $(OCAMLPACKAGES) \
+ $(daemon_utils_tests_THEOBJECTS) -o $@
+
# Manual pages and HTML files for the website.
if INSTALL_DAEMON
man_MANS = guestfsd.8
diff --git a/daemon/daemon_utils_tests.ml b/daemon/daemon_utils_tests.ml
new file mode 100644
index 000000000..892509d89
--- /dev/null
+++ b/daemon/daemon_utils_tests.ml
@@ -0,0 +1,48 @@
+(* 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 Utils
+
+(* Test prog_exists. *)
+let () + assert (prog_exists "ls");
+ assert (prog_exists "true")
+
+(* Test command, commandr. *)
+let () + ignore (command "true" []);
+
+ let r, _, _ = commandr "false" [] in
+ assert (r = 1)
+
+(* Test split_device_partition. *)
+let () + assert (split_device_partition "/dev/sda1" =
("sda", 1));
+ assert (split_device_partition "/dev/sdb" = ("sdb", 0));
+ assert (split_device_partition "/dev/ubda9" = ("ubda",
9));
+ assert (split_device_partition "/dev/md0p1" = ("md0", 1))
+ (* XXX The function is buggy:
+ assert (split_device_partition "/dev/md0" = ("md0", 0))
*)
+
+(* Test proc_unmangle_path. *)
+let () + assert (proc_unmangle_path "\\040" = " ");
+ assert (proc_unmangle_path "\\040\\040" = " ")
diff --git a/daemon/dummy.c b/daemon/dummy.c
new file mode 100644
index 000000000..ebab6198c
--- /dev/null
+++ b/daemon/dummy.c
@@ -0,0 +1,2 @@
+/* Dummy source, to be used for OCaml-based tools with no C sources. */
+enum { foo = 1 };
diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index 7bb6d5143..5f76499f7 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -97,6 +97,7 @@ daemon/dispatch.c
daemon/dmesg.c
daemon/dropcaches.c
daemon/du.c
+daemon/dummy.c
daemon/echo-daemon.c
daemon/ext2.c
daemon/fallocate.c
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 06/23] daemon: Reimplement ‘is_dir’, ‘is_file’ and ‘is_symlink’ APIs in OCaml.
This also demonstrates usage of optional arguments.
---
daemon/Makefile.am | 2 ++
daemon/is.c | 41 -----------------------------------------
daemon/is.ml | 42 ++++++++++++++++++++++++++++++++++++++++++
daemon/is.mli | 21 +++++++++++++++++++++
generator/actions_core.ml | 3 +++
5 files changed, 68 insertions(+), 41 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index f1b395725..090a80329 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -247,6 +247,7 @@ SOURCES_MLI = \
sysroot.mli \
devsparts.mli \
file.mli \
+ is.mli \
mountable.mli \
utils.mli
@@ -261,6 +262,7 @@ SOURCES_ML = \
blkid.ml \
devsparts.ml \
file.ml \
+ is.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/is.c b/daemon/is.c
index 4d5e911c2..a91dab32b 100644
--- a/daemon/is.c
+++ b/daemon/is.c
@@ -39,36 +39,6 @@ do_exists (const char *path)
/* Takes optional arguments, consult optargs_bitmask. */
int
-do_is_file (const char *path, int followsymlinks)
-{
- mode_t mode;
- int r;
-
- if (!(optargs_bitmask & GUESTFS_IS_FILE_FOLLOWSYMLINKS_BITMASK))
- followsymlinks = 0;
-
- r = get_mode (path, &mode, followsymlinks);
- if (r <= 0) return r;
- return S_ISREG (mode);
-}
-
-/* Takes optional arguments, consult optargs_bitmask. */
-int
-do_is_dir (const char *path, int followsymlinks)
-{
- mode_t mode;
- int r;
-
- if (!(optargs_bitmask & GUESTFS_IS_DIR_FOLLOWSYMLINKS_BITMASK))
- followsymlinks = 0;
-
- r = get_mode (path, &mode, followsymlinks);
- if (r <= 0) return r;
- return S_ISDIR (mode);
-}
-
-/* Takes optional arguments, consult optargs_bitmask. */
-int
do_is_chardev (const char *path, int followsymlinks)
{
mode_t mode;
@@ -112,17 +82,6 @@ do_is_fifo (const char *path, int followsymlinks)
return S_ISFIFO (mode);
}
-int
-do_is_symlink (const char *path)
-{
- mode_t mode;
- int r;
-
- r = get_mode (path, &mode, 0);
- if (r <= 0) return r;
- return S_ISLNK (mode);
-}
-
/* Takes optional arguments, consult optargs_bitmask. */
int
do_is_socket (const char *path, int followsymlinks)
diff --git a/daemon/is.ml b/daemon/is.ml
new file mode 100644
index 000000000..4929f48b3
--- /dev/null
+++ b/daemon/is.ml
@@ -0,0 +1,42 @@
+(* 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
+
+let rec is_file ?(followsymlinks = false) path + is "is_file" S_REG
followsymlinks path
+and is_dir ?(followsymlinks = false) path + is "is_dir" S_DIR
followsymlinks path
+and is_symlink path + is "is_symlink" S_LNK false path
+
+and is func expected_kind followsymlinks path + let chroot = Chroot.create
~name:(sprintf "%s: %s" func path) () in
+ let kind + Chroot.f chroot (
+ fun () ->
+ let statfun = if followsymlinks then stat else lstat in
+ try
+ let statbuf = statfun path in
+ Some statbuf.st_kind
+ with
+ Unix_error ((ENOENT|ENOTDIR), _, _) ->
+ None (* File doesn't exist => return None *)
+ ) () in
+ kind = Some expected_kind
diff --git a/daemon/is.mli b/daemon/is.mli
new file mode 100644
index 000000000..20622c39f
--- /dev/null
+++ b/daemon/is.mli
@@ -0,0 +1,21 @@
+(* 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 is_file : ?followsymlinks:bool -> string -> bool
+val is_dir : ?followsymlinks:bool -> string -> bool
+val is_symlink : string -> bool
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 94391288f..421f3ac6b 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -2114,6 +2114,7 @@ See also C<guestfs_is_file>,
C<guestfs_is_dir>, C<guestfs_stat>." };
{ defaults with
name = "is_file"; added = (0, 0, 8);
style = RBool "fileflag", [String (Pathname, "path")],
[OBool "followsymlinks"];
+ impl = OCaml "Is.is_file";
once_had_no_optargs = true;
tests = [
InitISOFS, Always, TestResultTrue (
@@ -2138,6 +2139,7 @@ See also C<guestfs_stat>." };
{ defaults with
name = "is_dir"; added = (0, 0, 8);
style = RBool "dirflag", [String (Pathname, "path")],
[OBool "followsymlinks"];
+ impl = OCaml "Is.is_dir";
once_had_no_optargs = true;
tests = [
InitISOFS, Always, TestResultFalse (
@@ -6052,6 +6054,7 @@ See also C<guestfs_stat>." };
{ defaults with
name = "is_symlink"; added = (1, 5, 10);
style = RBool "flag", [String (Pathname, "path")], [];
+ impl = OCaml "Is.is_symlink";
tests = [
InitISOFS, Always, TestResultFalse (
[["is_symlink"; "/directory"]]), [];
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 07/23] daemon: Reimplement ‘readlink’ API in OCaml.
---
daemon/Makefile.am | 2 ++
daemon/link.c | 16 ----------------
daemon/link.ml | 24 ++++++++++++++++++++++++
daemon/link.mli | 19 +++++++++++++++++++
generator/actions_core.ml | 1 +
5 files changed, 46 insertions(+), 16 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 090a80329..ea9a5fc8f 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -248,6 +248,7 @@ SOURCES_MLI = \
devsparts.mli \
file.mli \
is.mli \
+ link.mli \
mountable.mli \
utils.mli
@@ -263,6 +264,7 @@ SOURCES_ML = \
devsparts.ml \
file.ml \
is.ml \
+ link.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/link.c b/daemon/link.c
index 0878fd32b..53f4719ed 100644
--- a/daemon/link.c
+++ b/daemon/link.c
@@ -30,22 +30,6 @@
#include "daemon.h"
#include "actions.h"
-char *
-do_readlink (const char *path)
-{
- char *link;
-
- CHROOT_IN;
- link = areadlink (path);
- CHROOT_OUT;
- if (link == NULL) {
- reply_with_perror ("%s", path);
- return NULL;
- }
-
- return link; /* caller frees */
-}
-
char **
do_internal_readlinklist (const char *path, char *const *names)
{
diff --git a/daemon/link.ml b/daemon/link.ml
new file mode 100644
index 000000000..e80e24aa5
--- /dev/null
+++ b/daemon/link.ml
@@ -0,0 +1,24 @@
+(* 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
+
+let readlink path + let chroot = Chroot.create ~name:(sprintf "readlink:
%s" path) () in
+ Chroot.f chroot readlink path
diff --git a/daemon/link.mli b/daemon/link.mli
new file mode 100644
index 000000000..6ca0283b4
--- /dev/null
+++ b/daemon/link.mli
@@ -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.
+ *)
+
+val readlink : string -> string
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 421f3ac6b..7d6755fdc 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -4489,6 +4489,7 @@ The I<-f> option removes the link
(C<linkname>) if it exists already." };
{ defaults with
name = "readlink"; added = (1, 0, 66);
style = RString (RPlainString, "link"), [String (Pathname,
"path")], [];
+ impl = OCaml "Link.readlink";
shortdesc = "read the target of a symbolic link";
longdesc = "\
This command reads the target of a symbolic link." };
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 08/23] daemon: Reimplement ‘mount’, ‘mount_ro’, ‘mount_options’, ‘mount_vfs’ APIs in OCaml.
Some of the oldest and most core APIs, reimplemented.
This also moves the strange ‘mount_vfs_nochroot’ function into
btrfs.c.
---
daemon/Makefile.am | 2 +
daemon/btrfs.c | 42 ++++++++++++++++++++
daemon/daemon.h | 3 --
daemon/mount.c | 99 -----------------------------------------------
daemon/mount.ml | 62 +++++++++++++++++++++++++++++
daemon/mount.mli | 22 +++++++++++
generator/actions_core.ml | 4 ++
7 files changed, 132 insertions(+), 102 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index ea9a5fc8f..3b527e10f 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -249,6 +249,7 @@ SOURCES_MLI = \
file.mli \
is.mli \
link.mli \
+ mount.mli \
mountable.mli \
utils.mli
@@ -265,6 +266,7 @@ SOURCES_ML = \
file.ml \
is.ml \
link.ml \
+ mount.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/btrfs.c b/daemon/btrfs.c
index 8fd327c09..00c9b3c75 100644
--- a/daemon/btrfs.c
+++ b/daemon/btrfs.c
@@ -380,6 +380,48 @@ do_btrfs_subvolume_create (const char *dest, const char
*qgroupid)
return 0;
}
+static int
+mount_vfs_nochroot (const char *options, const char *vfstype,
+ const mountable_t *mountable,
+ const char *mp, const char *user_mp)
+{
+ CLEANUP_FREE char *options_plus = NULL;
+ const char *device = mountable->device;
+ if (mountable->type == MOUNTABLE_BTRFSVOL) {
+ if (options && strlen (options) > 0) {
+ if (asprintf (&options_plus, "subvol=%s,%s",
+ mountable->volume, options) == -1) {
+ reply_with_perror ("asprintf");
+ return -1;
+ }
+ }
+ else {
+ if (asprintf (&options_plus, "subvol=%s",
mountable->volume) == -1) {
+ reply_with_perror ("asprintf");
+ return -1;
+ }
+ }
+ }
+
+ CLEANUP_FREE char *error = NULL;
+ int r;
+ if (vfstype)
+ r = command (NULL, &error,
+ "mount", "-o", options_plus ? options_plus
: options,
+ "-t", vfstype, device, mp, NULL);
+ else
+ r = command (NULL, &error,
+ "mount", "-o", options_plus ? options_plus
: options,
+ device, mp, NULL);
+ if (r == -1) {
+ reply_with_error ("%s on %s (options: '%s'): %s",
+ device, user_mp, options, error);
+ return -1;
+ }
+
+ return 0;
+}
+
static char *
mount (const mountable_t *fs)
{
diff --git a/daemon/daemon.h b/daemon/daemon.h
index 4acc9c9fe..0f7ead258 100644
--- a/daemon/daemon.h
+++ b/daemon/daemon.h
@@ -109,9 +109,6 @@ extern void cleanup_free_stringsbuf (void *ptr);
#endif
/* mount.c */
-extern int mount_vfs_nochroot (const char *options, const char *vfstype,
- const mountable_t *mountable,
- const char *mp, const char *user_mp);
extern int is_root_mounted (void);
extern int is_device_mounted (const char *device);
diff --git a/daemon/mount.c b/daemon/mount.c
index f9dfaff70..bf58bd527 100644
--- a/daemon/mount.c
+++ b/daemon/mount.c
@@ -108,105 +108,6 @@ is_device_mounted (const char *device)
return 0;
}
-/* The "simple mount" call offers no complex options, you can just
- * mount a device on a mountpoint. The variations like mount_ro,
- * mount_options and mount_vfs let you set progressively more things.
- *
- * It's tempting to try a direct mount(2) syscall, but that doesn't
- * do any autodetection, so we are better off calling out to
- * /bin/mount.
- */
-
-int
-do_mount_vfs (const char *options, const char *vfstype,
- const mountable_t *mountable, const char *mountpoint)
-{
- CLEANUP_FREE char *mp = NULL;
- struct stat statbuf;
-
- ABS_PATH (mountpoint, 0, return -1);
-
- mp = sysroot_path (mountpoint);
- if (!mp) {
- reply_with_perror ("malloc");
- return -1;
- }
-
- /* Check the mountpoint exists and is a directory. */
- if (stat (mp, &statbuf) == -1) {
- reply_with_perror ("mount: %s", mountpoint);
- return -1;
- }
- if (!S_ISDIR (statbuf.st_mode)) {
- reply_with_perror ("mount: %s: mount point is not a directory",
mountpoint);
- return -1;
- }
-
- return mount_vfs_nochroot (options, vfstype, mountable, mp, mountpoint);
-}
-
-int
-mount_vfs_nochroot (const char *options, const char *vfstype,
- const mountable_t *mountable,
- const char *mp, const char *user_mp)
-{
- CLEANUP_FREE char *options_plus = NULL;
- const char *device = mountable->device;
- if (mountable->type == MOUNTABLE_BTRFSVOL) {
- if (options && strlen (options) > 0) {
- if (asprintf (&options_plus, "subvol=%s,%s",
- mountable->volume, options) == -1) {
- reply_with_perror ("asprintf");
- return -1;
- }
- }
-
- else {
- if (asprintf (&options_plus, "subvol=%s",
mountable->volume) == -1) {
- reply_with_perror ("asprintf");
- return -1;
- }
- }
- }
-
- CLEANUP_FREE char *error = NULL;
- int r;
- if (vfstype)
- r = command (NULL, &error,
- "mount", "-o", options_plus ? options_plus
: options,
- "-t", vfstype, device, mp, NULL);
- else
- r = command (NULL, &error,
- "mount", "-o", options_plus ? options_plus
: options,
- device, mp, NULL);
- if (r == -1) {
- reply_with_error ("%s on %s (options: '%s'): %s",
- device, user_mp, options, error);
- return -1;
- }
-
- return 0;
-}
-
-int
-do_mount (const mountable_t *mountable, const char *mountpoint)
-{
- return do_mount_vfs ("", NULL, mountable, mountpoint);
-}
-
-int
-do_mount_ro (const mountable_t *mountable, const char *mountpoint)
-{
- return do_mount_vfs ("ro", NULL, mountable, mountpoint);
-}
-
-int
-do_mount_options (const char *options, const mountable_t *mountable,
- const char *mountpoint)
-{
- return do_mount_vfs (options, NULL, mountable, mountpoint);
-}
-
/* Takes optional arguments, consult optargs_bitmask. */
int
do_umount (const char *pathordevice,
diff --git a/daemon/mount.ml b/daemon/mount.ml
new file mode 100644
index 000000000..3391ffc11
--- /dev/null
+++ b/daemon/mount.ml
@@ -0,0 +1,62 @@
+(* 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
+
+open Mountable
+open Utils
+
+let mount_vfs options vfs mountable mountpoint + let mp = Sysroot.sysroot_path
mountpoint in
+
+ (* Check the mountpoint exists and is a directory. *)
+ if not (is_directory mp) then
+ failwithf "mount: %s: mount point is not a directory" mountpoint;
+
+ let args = ref [] in
+
+ (* -o options *)
+ (match options, mountable.m_type with
+ | (None | Some ""), (MountableDevice | MountablePath) -> ()
+ | Some options, (MountableDevice | MountablePath) ->
+ push_back args "-o";
+ push_back args options
+ | (None | Some ""), MountableBtrfsVol subvol ->
+ push_back args "-o";
+ push_back args ("subvol=" ^ subvol)
+ | Some options, MountableBtrfsVol subvol ->
+ push_back args "-o";
+ push_back args ("subvol=" ^ subvol ^ "," ^ options)
+ );
+
+ (* -t vfs *)
+ (match vfs with
+ | None | Some "" -> ()
+ | Some t ->
+ push_back args "-t";
+ push_back args t
+ );
+
+ push_back args mountable.m_device;
+ push_back args mp;
+
+ ignore (command "mount" !args)
+
+let mount = mount_vfs None None
+let mount_ro = mount_vfs (Some "ro") None
+let mount_options options = mount_vfs (Some options) None
diff --git a/daemon/mount.mli b/daemon/mount.mli
new file mode 100644
index 000000000..e43d97c42
--- /dev/null
+++ b/daemon/mount.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 mount : Mountable.t -> string -> unit
+val mount_ro : Mountable.t -> string -> unit
+val mount_options : string -> Mountable.t -> string -> unit
+val mount_vfs : string option -> string option -> Mountable.t ->
string -> unit
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 7d6755fdc..f33bc5320 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -1739,6 +1739,7 @@ let daemon_functions = [
{ defaults with
name = "mount"; added = (0, 0, 3);
style = RErr, [String (Mountable, "mountable"); String
(PlainString, "mountpoint")], [];
+ impl = OCaml "Mount.mount";
tests = [
InitEmpty, Always, TestResultString (
[["part_disk"; "/dev/sda"; "mbr"];
@@ -2922,6 +2923,7 @@ If set to true, POSIX ACLs are saved in the output tar.
{ defaults with
name = "mount_ro"; added = (1, 0, 10);
style = RErr, [String (Mountable, "mountable"); String
(PlainString, "mountpoint")], [];
+ impl = OCaml "Mount.mount_ro";
tests = [
InitBasicFS, Always, TestLastFail (
[["umount"; "/"; "false";
"false"];
@@ -2941,6 +2943,7 @@ mounts the filesystem with the read-only (I<-o ro>)
flag." };
{ defaults with
name = "mount_options"; added = (1, 0, 10);
style = RErr, [String (PlainString, "options"); String
(Mountable, "mountable"); String (PlainString,
"mountpoint")], [];
+ impl = OCaml "Mount.mount_options";
shortdesc = "mount a guest disk with mount options";
longdesc = "\
This is the same as the C<guestfs_mount> command, but it
@@ -2954,6 +2957,7 @@ the filesystem uses)." };
{ defaults with
name = "mount_vfs"; added = (1, 0, 10);
style = RErr, [String (PlainString, "options"); String
(PlainString, "vfstype"); String (Mountable, "mountable");
String (PlainString, "mountpoint")], [];
+ impl = OCaml "Mount.mount_vfs";
shortdesc = "mount a guest disk with mount options and vfstype";
longdesc = "\
This is the same as the C<guestfs_mount> command, but it
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 09/23] daemon: Reimplement ‘part_get_mbr_id’ API in OCaml.
---
daemon/Makefile.am | 2 ++
daemon/parted.c | 42 ------------------------------------
daemon/parted.ml | 55 +++++++++++++++++++++++++++++++++++++++++++++++
daemon/parted.mli | 19 ++++++++++++++++
generator/actions_core.ml | 1 +
5 files changed, 77 insertions(+), 42 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 3b527e10f..195b2e0a7 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -251,6 +251,7 @@ SOURCES_MLI = \
link.mli \
mount.mli \
mountable.mli \
+ parted.mli \
utils.mli
SOURCES_ML = \
@@ -267,6 +268,7 @@ SOURCES_ML = \
is.ml \
link.ml \
mount.ml \
+ parted.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/parted.c b/daemon/parted.c
index 7446bc93e..b788ed72a 100644
--- a/daemon/parted.c
+++ b/daemon/parted.c
@@ -517,48 +517,6 @@ test_sfdisk_has_part_type (void)
return tested;
}
-/* Currently we use sfdisk for getting and setting the ID byte. In
- * future, extend parted to provide this functionality. As a result
- * of using sfdisk, this won't work for non-MBR-style partitions, but
- * that limitation is noted in the documentation and we can extend it
- * later without breaking the ABI.
- */
-int
-do_part_get_mbr_id (const char *device, int partnum)
-{
- if (partnum <= 0) {
- reply_with_error ("partition number must be >= 1");
- return -1;
- }
-
- const char *param = test_sfdisk_has_part_type () ? "--part-type" :
"--print-id";
-
- char partnum_str[16];
- snprintf (partnum_str, sizeof partnum_str, "%d", partnum);
-
- CLEANUP_FREE char *out = NULL, *err = NULL;
- int r;
-
- udev_settle ();
-
- r = command (&out, &err, "sfdisk", param, device,
partnum_str, NULL);
- if (r == -1) {
- reply_with_error ("sfdisk %s: %s", param, err);
- return -1;
- }
-
- udev_settle ();
-
- /* It's printed in hex ... */
- unsigned id;
- if (sscanf (out, "%x", &id) != 1) {
- reply_with_error ("sfdisk --print-id: cannot parse output: %s",
out);
- return -1;
- }
-
- return id;
-}
-
int
do_part_set_mbr_id (const char *device, int partnum, int idbyte)
{
diff --git a/daemon/parted.ml b/daemon/parted.ml
new file mode 100644
index 000000000..6be41cf66
--- /dev/null
+++ b/daemon/parted.ml
@@ -0,0 +1,55 @@
+(* 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 Scanf
+
+open Std_utils
+
+open Utils
+
+(* Test if [sfdisk] is recent enough to have [--part-type], to be used
+ * instead of [--print-id] and [--change-id].
+ *)
+let test_sfdisk_has_part_type = lazy (
+ let out = command "sfdisk" ["--help"] in
+ String.find out "--part-type" >= 0
+)
+
+(* Currently we use sfdisk for getting and setting the ID byte. In
+ * future, extend parted to provide this functionality. As a result
+ * of using sfdisk, this won't work for non-MBR-style partitions, but
+ * that limitation is noted in the documentation and we can extend it
+ * later without breaking the ABI.
+ *)
+let part_get_mbr_id device partnum + if partnum <= 0 then
+ failwith "partition number must be >= 1";
+
+ let param + if Lazy.force test_sfdisk_has_part_type then
+ "--part-type"
+ else
+ "--print-id" in
+
+ udev_settle ();
+ let out + command "sfdisk" [param; device; string_of_int
partnum] in
+ udev_settle ();
+
+ (* It's printed in hex, possibly with a leading space. *)
+ sscanf out " %x" identity
diff --git a/daemon/parted.mli b/daemon/parted.mli
new file mode 100644
index 000000000..33eb6d30d
--- /dev/null
+++ b/daemon/parted.mli
@@ -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.
+ *)
+
+val part_get_mbr_id : string -> int -> int
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index f33bc5320..4bf0c7b70 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -5513,6 +5513,7 @@ See also C<guestfs_part_set_bootable>." };
{ defaults with
name = "part_get_mbr_id"; added = (1, 3, 2);
style = RInt "idbyte", [String (Device, "device"); Int
"partnum"], [];
+ impl = OCaml "Parted.part_get_mbr_id";
fish_output = Some FishOutputHexadecimal;
tests = [
InitEmpty, Always, TestResult (
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 10/23] daemon: Reimplement ‘case_sensitive_path’ API in OCaml.
---
daemon/Makefile.am | 2 +
daemon/realpath.c | 187 ----------------------------------------------
daemon/realpath.ml | 82 ++++++++++++++++++++
daemon/realpath.mli | 19 +++++
generator/actions_core.ml | 1 +
5 files changed, 104 insertions(+), 187 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 195b2e0a7..9927bb47c 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -252,6 +252,7 @@ SOURCES_MLI = \
mount.mli \
mountable.mli \
parted.mli \
+ realpath.mli \
utils.mli
SOURCES_ML = \
@@ -269,6 +270,7 @@ SOURCES_ML = \
link.ml \
mount.ml \
parted.ml \
+ realpath.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/realpath.c b/daemon/realpath.c
index 24ab133e2..f9d22d28d 100644
--- a/daemon/realpath.c
+++ b/daemon/realpath.c
@@ -48,190 +48,3 @@ do_realpath (const char *path)
return ret; /* caller frees */
}
-
-static int find_path_element (int fd_cwd, int is_end, const char *name, char
**name_ret);
-
-char *
-do_case_sensitive_path (const char *path)
-{
- size_t next;
- int fd_cwd, fd2, err, is_end;
- char *ret;
-
- ret = strdup ("/");
- if (ret == NULL) {
- reply_with_perror ("strdup");
- return NULL;
- }
- next = 1; /* next position in 'ret' buffer */
-
- /* 'fd_cwd' here is a surrogate for the current working directory, so
- * that we don't have to actually call chdir(2).
- */
- fd_cwd = open (sysroot, O_RDONLY|O_DIRECTORY|O_CLOEXEC);
- if (fd_cwd == -1) {
- reply_with_perror ("%s", sysroot);
- goto error;
- }
-
- /* First character is a '/'. Take each subsequent path element
- * and follow it.
- */
- while (*path) {
- char *t;
- size_t i, len;
- CLEANUP_FREE char *name_in = NULL, *name_out = NULL;
-
- i = strcspn (path, "/");
- if (i == 0) {
- path++;
- continue;
- }
-
- if ((i == 1 && path[0] == '.') ||
- (i == 2 && path[0] == '.' && path[1] ==
'.')) {
- reply_with_error ("path contained . or .. elements");
- goto error;
- }
-
- name_in = strndup (path, i);
- if (name_in == NULL) {
- reply_with_perror ("strdup");
- goto error;
- }
-
- /* Skip to next element in path (for the next loop iteration). */
- path += i;
- is_end = *path == 0;
-
- /* Read the current directory looking (case insensitively) for
- * this element of the path. This replaces 'name' with the
- * correct case version.
- */
- if (find_path_element (fd_cwd, is_end, name_in, &name_out) == -1)
- goto error;
- len = strlen (name_out);
-
- /* Add the real name of this path element to the return value. */
- if (next > 1)
- ret[next++] = '/';
-
- t = realloc (ret, next+len+1);
- if (t == NULL) {
- reply_with_perror ("realloc");
- goto error;
- }
- ret = t;
-
- strcpy (&ret[next], name_out);
- next += len;
-
- /* Is it a directory? Try going into it. */
- fd2 = openat (fd_cwd, name_out, O_RDONLY|O_DIRECTORY|O_CLOEXEC);
- err = errno;
- close (fd_cwd);
- fd_cwd = fd2;
- errno = err;
- if (fd_cwd == -1) {
- /* Some errors are OK provided we've reached the end of the path. */
- if (is_end && (errno == ENOTDIR || errno == ENOENT))
- break;
-
- reply_with_perror ("openat: %s", name_out);
- goto error;
- }
- }
-
- if (fd_cwd >= 0)
- close (fd_cwd);
-
- return ret; /* caller frees */
-
- error:
- if (fd_cwd >= 0)
- close (fd_cwd);
- free (ret);
-
- return NULL;
-}
-
-/* 'fd_cwd' is a file descriptor pointing to an open directory.
- * 'name' is the path element to search for. 'is_end' is a
flag
- * indicating if this is the last path element.
- *
- * We search the directory looking for a path element that case
- * insensitively matches 'name', returning the actual name in
'*name_ret'.
- *
- * If this is successful, return 0. If it fails, reply with an error
- * and return -1.
- */
-static int
-find_path_element (int fd_cwd, int is_end, const char *name, char **name_ret)
-{
- int fd2;
- DIR *dir;
- struct dirent *d;
-
- fd2 = dup_cloexec (fd_cwd); /* because closedir will close it */
- if (fd2 == -1) {
- reply_with_perror ("dup");
- return -1;
- }
- dir = fdopendir (fd2);
- if (dir == NULL) {
- reply_with_perror ("opendir");
- close (fd2);
- return -1;
- }
-
- for (;;) {
- errno = 0;
- d = readdir (dir);
- if (d == NULL)
- break;
- if (STRCASEEQ (d->d_name, name))
- break;
- }
-
- if (d == NULL && errno != 0) {
- reply_with_perror ("readdir");
- closedir (dir);
- return -1;
- }
-
- if (d == NULL && is_end) {
- /* Last path element: return it as-is, assuming that the user will
- * create a new file or directory (RHBZ#840115).
- */
- closedir (dir);
- *name_ret = strdup (name);
- if (*name_ret == NULL) {
- reply_with_perror ("strdup");
- return -1;
- }
- return 0;
- }
-
- if (d == NULL) {
- reply_with_error ("%s: no file or directory found with this
name", name);
- closedir (dir);
- return -1;
- }
-
- *name_ret = strdup (d->d_name);
- if (*name_ret == NULL) {
- reply_with_perror ("strdup");
- closedir (dir);
- return -1;
- }
-
- /* NB: closedir frees the structure associated with 'd', so we must
- * do this last.
- */
- if (closedir (dir) == -1) {
- reply_with_perror ("closedir");
- return -1;
- }
-
- return 0;
-}
diff --git a/daemon/realpath.ml b/daemon/realpath.ml
new file mode 100644
index 000000000..e499786a1
--- /dev/null
+++ b/daemon/realpath.ml
@@ -0,0 +1,82 @@
+(* 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 Std_utils
+
+(* The infamous case_sensitive_path function, which works around
+ * the bug in ntfs-3g that all paths are case sensitive even though
+ * the underlying filesystem is case insensitive.
+ *)
+let rec case_sensitive_path path + let elems = String.nsplit "/"
path in
+
+ (* The caller ensures that the first element of [path] is [/],
+ * and therefore the first element of the split list must be
+ * empty.
+ *)
+ assert (List.length elems > 0);
+ assert (List.hd elems = "");
+ let elems = List.tl elems in
+
+ let chroot + Chroot.create ~name:(sprintf "case_sensitive_path:
%s" path) () in
+
+ (* Now we iterate down the tree starting at the sysroot. *)
+ let elems + Chroot.f chroot (
+ fun () ->
+ let rec loop = function
+ | [] -> []
+ | [ "."|".." ] ->
+ failwithf "path contains \".\" or \"..\"
elements"
+ | "" :: elems ->
+ (* For compatibility with C implementation, we ignore
+ * "//" in the middle of the path.
+ *)
+ loop elems
+ | [ file ] ->
+ (* If it's the final element, it's allowed to be missing.
*)
+ (match find_path_element file with
+ | None -> [ file ] (* return the original *)
+ | Some file -> [ file ]
+ );
+ | elem :: elems ->
+ (match find_path_element elem with
+ | None ->
+ failwithf "%s: not found" elem
+ | Some elem ->
+ (* This will fail intentionally if not a directory. *)
+ Unix.chdir elem;
+ elem :: loop elems
+ )
+ in
+ loop elems
+ ) () in
+
+ (* Reconstruct the case sensitive path. *)
+ "/" ^ String.concat "/" elems
+
+and find_path_element name + let dir = Sys.readdir "." in
+ let dir = Array.to_list dir in
+ let lc_name = String.lowercase_ascii name in
+ let cmp n = String.lowercase_ascii n = lc_name in
+ try Some (List.find cmp dir)
+ with Not_found -> None
diff --git a/daemon/realpath.mli b/daemon/realpath.mli
new file mode 100644
index 000000000..371e619fc
--- /dev/null
+++ b/daemon/realpath.mli
@@ -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.
+ *)
+
+val case_sensitive_path : string -> string
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 4bf0c7b70..54d0a6ca8 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -4797,6 +4797,7 @@ The result list is not sorted.
{ defaults with
name = "case_sensitive_path"; added = (1, 0, 75);
style = RString (RPlainString, "rpath"), [String (Pathname,
"path")], [];
+ impl = OCaml "Realpath.case_sensitive_path";
tests = [
InitISOFS, Always, TestResultString (
[["case_sensitive_path"; "/DIRECTORY"]],
"/directory"), [];
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 11/23] daemon: Reimplement ‘file_architecture’ API in OCaml.
The previously library-side ‘file_architecture’ API is reimplemented
in the daemon, in OCaml.
There are some significant differences compared to the C
implementation:
- The C code used libmagic. That is replaced by calling the ‘file’
command (because that is simpler than using the library).
- The C code had extra cases to deal with compressed files. This is
not necessary since the ‘file’ command supports the ‘-z’ option
which transparently looks inside compressed content (this is a
consequence of the change above).
This commit demonstrates a number of techniques which will be useful
for moving inspection code to the daemon:
- Moving an API from the C library to the OCaml daemon.
- Calling from one OCaml API inside the daemon to another (from
‘Filearch.file_architecture’ to ‘File.file’). This can be done and
is done with C daemon APIs but correct reply_with_error handling is
more difficult in C.
- Use of Str for regular expression matching within the appliance.
---
daemon/Makefile.am | 2 +
daemon/filearch.ml | 140 +++++++++++++++++
daemon/filearch.mli | 19 +++
docs/C_SOURCE_FILES | 1 -
generator/actions_core.ml | 377 +++++++++++++++++++++++-----------------------
generator/proc_nr.ml | 1 +
lib/MAX_PROC_NR | 2 +-
lib/Makefile.am | 3 +-
lib/filearch.c | 362 --------------------------------------------
po/POTFILES | 1 -
10 files changed, 353 insertions(+), 555 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 9927bb47c..31cb01b85 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -247,6 +247,7 @@ SOURCES_MLI = \
sysroot.mli \
devsparts.mli \
file.mli \
+ filearch.mli \
is.mli \
link.mli \
mount.mli \
@@ -266,6 +267,7 @@ SOURCES_ML = \
blkid.ml \
devsparts.ml \
file.ml \
+ filearch.ml \
is.ml \
link.ml \
mount.ml \
diff --git a/daemon/filearch.ml b/daemon/filearch.ml
new file mode 100644
index 000000000..505d8c78e
--- /dev/null
+++ b/daemon/filearch.ml
@@ -0,0 +1,140 @@
+(* 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
+open Unix_utils
+
+open Utils
+
+let re_file_elf + Str.regexp ".*ELF \\([0-9]+\\)-bit
\\(MSB\\|LSB\\).*\\(executable\\|shared object\\|relocatable\\),
\\([^,]+\\),"
+
+let re_file_elf_ppc64 = Str.regexp ".*64.*PowerPC"
+
+let initrd_binaries = [
+ "bin/ls";
+ "bin/rm";
+ "bin/modprobe";
+ "sbin/modprobe";
+ "bin/sh";
+ "bin/bash";
+ "bin/dash";
+ "bin/nash";
+]
+
+let rec file_architecture orig_path + (* Get the output of the
"file" command. Note that because this
+ * is running in the daemon, LANG=C so it's in English.
+ *)
+ let magic = File.file orig_path in
+ file_architecture_of_magic magic orig_path orig_path
+
+and file_architecture_of_magic magic orig_path path + if Str.string_match
re_file_elf magic 0 then (
+ let bits = Str.matched_group 1 magic in
+ let endianness = Str.matched_group 2 magic in
+ let elf_arch = Str.matched_group 4 magic in
+ canonical_elf_arch bits endianness elf_arch
+ )
+ else if String.find magic "PE32 executable" >= 0 then
+ "i386"
+ else if String.find magic "PE32+ executable" >= 0 then
+ "x86_64"
+ else if String.find magic "cpio archive" >= 0 then
+ cpio_arch magic orig_path path
+ else
+ failwithf "unknown architecture: %s" path
+
+(* Convert output from 'file' command on ELF files to the canonical
+ * architecture string.
+ *)
+and canonical_elf_arch bits endianness elf_arch + let substr s = String.find
elf_arch s >= 0 in
+ if substr "Intel 80386" || substr "Intel 80486" then
+ "i386"
+ else if substr "x86-64" || substr "AMD x86-64" then
+ "x86_64"
+ else if substr "SPARC32" then
+ "sparc"
+ else if substr "SPARC V9" then
+ "sparc64"
+ else if substr "IA-64" then
+ "ia64"
+ else if Str.string_match re_file_elf_ppc64 elf_arch 0 then (
+ match endianness with
+ | "MSB" -> "ppc64"
+ | "LSB" -> "ppc64le"
+ | _ -> failwithf "unknown endianness '%s'" endianness
+ )
+ else if substr "PowerPC" then
+ "ppc"
+ else if substr "ARM aarch64" then
+ "aarch64"
+ else if substr "ARM" then
+ "arm"
+ else if substr "UCB RISC-V" then
+ sprintf "riscv%s" bits
+ else if substr "IBM S/390" then (
+ match bits with
+ | "32" -> "s390"
+ | "64" -> "s390x"
+ | _ -> failwithf "unknown S/390 bit size: %s" bits
+ )
+ else
+ elf_arch
+
+and cpio_arch magic orig_path path + let zcat + if String.find magic
"gzip" >= 0 then "zcat"
+ else if String.find magic "bzip2" >= 0 then "bzcat"
+ else if String.find magic "XZ compressed" >= 0 then
"xzcat"
+ else "cat" in
+
+ let tmpdir = Mkdtemp.temp_dir "filearch" in
+ let finally () = ignore (Sys.command (sprintf "rm -rf %s" (quote
tmpdir))) in
+
+ protect ~finally ~f:(
+ fun () ->
+ (* Construct a command to extract named binaries from the initrd file. *)
+ let cmd + sprintf "cd %s && %s %s | cpio --quiet -id
%s"
+ tmpdir zcat (quote (Sysroot.sysroot_path path))
+ (String.concat " " (List.map quote initrd_binaries))
in
+ if verbose () then eprintf "%s\n%!" cmd;
+ if Sys.command cmd <> 0 then
+ failwith "cpio command failed";
+
+ (* See if any of the binaries were present in the output. *)
+ let rec loop = function
+ | bin :: bins ->
+ let bin_path = tmpdir // bin in
+ if is_regular_file bin_path then (
+ let out = command "file" ["-zb"; bin_path] in
+ file_architecture_of_magic out orig_path bin_path
+ )
+ else
+ loop bins
+ | [] ->
+ failwithf "could not determine architecture of cpio archive:
%s"
+ path
+ in
+ loop initrd_binaries
+ )
diff --git a/daemon/filearch.mli b/daemon/filearch.mli
new file mode 100644
index 000000000..c4630225b
--- /dev/null
+++ b/daemon/filearch.mli
@@ -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.
+ *)
+
+val file_architecture : string -> string
diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index 5f76499f7..7ac6716cd 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -300,7 +300,6 @@ lib/errors.c
lib/event-string.c
lib/events.c
lib/file.c
-lib/filearch.c
lib/fuse.c
lib/guestfs-internal-actions.h
lib/guestfs-internal-all.h
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 54d0a6ca8..bfd96589e 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -183,194 +183,6 @@ making this an unreliable way to test for features.
Use C<guestfs_available> or C<guestfs_feature_available>
instead." };
{ defaults with
- name = "file_architecture"; added = (1, 5, 3);
- style = RString (RPlainString, "arch"), [String (Pathname,
"filename")], [];
- tests = [
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-aarch64-dynamic"]],
"aarch64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-armv7-dynamic"]],
"arm"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-i586-dynamic"]],
"i386"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-ppc64-dynamic"]],
"ppc64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-ppc64le-dynamic"]],
"ppc64le"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-riscv64-dynamic"]],
"riscv64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-s390x-dynamic"]],
"s390x"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-sparc-dynamic"]],
"sparc"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-win32.exe"]],
"i386"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-win64.exe"]],
"x86_64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-x86_64-dynamic"]],
"x86_64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-aarch64.so"]],
"aarch64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-armv7.so"]],
"arm"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-i586.so"]],
"i386"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-ppc64.so"]],
"ppc64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-ppc64le.so"]],
"ppc64le"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-riscv64.so"]],
"riscv64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-s390x.so"]],
"s390x"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-sparc.so"]],
"sparc"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-win32.dll"]],
"i386"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-win64.dll"]],
"x86_64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-x86_64.so"]],
"x86_64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/initrd-x86_64.img"]],
"x86_64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/initrd-x86_64.img.gz"]],
"x86_64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/bin-x86_64-dynamic.gz"]],
"x86_64"), [];
- InitISOFS, Always, TestResultString (
- [["file_architecture"; "/lib-i586.so.xz"]],
"i386"), [];
- ];
- shortdesc = "detect the architecture of a binary file";
- longdesc = "\
-This detects the architecture of the binary F<filename>,
-and returns it if known.
-
-Currently defined architectures are:
-
-=over 4
-
-=item \"aarch64\"
-
-64 bit ARM.
-
-=item \"arm\"
-
-32 bit ARM.
-
-=item \"i386\"
-
-This string is returned for all 32 bit i386, i486, i586, i686 binaries
-irrespective of the precise processor requirements of the binary.
-
-=item \"ia64\"
-
-Intel Itanium.
-
-=item \"ppc\"
-
-32 bit Power PC.
-
-=item \"ppc64\"
-
-64 bit Power PC (big endian).
-
-=item \"ppc64le\"
-
-64 bit Power PC (little endian).
-
-=item \"riscv32\"
-
-=item \"riscv64\"
-
-=item \"riscv128\"
-
-RISC-V 32-, 64- or 128-bit variants.
-
-=item \"s390\"
-
-31 bit IBM S/390.
-
-=item \"s390x\"
-
-64 bit IBM S/390.
-
-=item \"sparc\"
-
-32 bit SPARC.
-
-=item \"sparc64\"
-
-64 bit SPARC V9 and above.
-
-=item \"x86_64\"
-
-64 bit x86-64.
-
-=back
-
-Libguestfs may return other architecture strings in future.
-
-The function works on at least the following types of files:
-
-=over 4
-
-=item *
-
-many types of Un*x and Linux binary
-
-=item *
-
-many types of Un*x and Linux shared library
-
-=item *
-
-Windows Win32 and Win64 binaries
-
-=item *
-
-Windows Win32 and Win64 DLLs
-
-Win32 binaries and DLLs return C<i386>.
-
-Win64 binaries and DLLs return C<x86_64>.
-
-=item *
-
-Linux kernel modules
-
-=item *
-
-Linux new-style initrd images
-
-=item *
-
-some non-x86 Linux vmlinuz kernels
-
-=back
-
-What it can't do currently:
-
-=over 4
-
-=item *
-
-static libraries (libfoo.a)
-
-=item *
-
-Linux old-style initrd as compressed ext2 filesystem (RHEL 3)
-
-=item *
-
-x86 Linux vmlinuz kernels
-
-x86 vmlinuz images (bzImage format) consist of a mix of 16-, 32- and
-compressed code, and are horribly hard to unpack. If you want to find
-the architecture of a kernel, use the architecture of the associated
-initrd or kernel module(s) instead.
-
-=back" };
-
- { defaults with
name = "mountable_device"; added = (1, 33, 15);
style = RString (RDevice, "device"), [String (Mountable,
"mountable")], [];
shortdesc = "extract the device part of a mountable";
@@ -9628,4 +9440,193 @@ wildcards.
Please note that this API may fail when used to compress directories
with large files, such as the resulting squashfs will be over 3GB big." };
+ { defaults with
+ name = "file_architecture"; added = (1, 5, 3);
+ style = RString (RPlainString, "arch"), [String (Pathname,
"filename")], [];
+ impl = OCaml "Filearch.file_architecture";
+ tests = [
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-aarch64-dynamic"]],
"aarch64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-armv7-dynamic"]],
"arm"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-i586-dynamic"]],
"i386"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-ppc64-dynamic"]],
"ppc64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-ppc64le-dynamic"]],
"ppc64le"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-riscv64-dynamic"]],
"riscv64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-s390x-dynamic"]],
"s390x"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-sparc-dynamic"]],
"sparc"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-win32.exe"]],
"i386"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-win64.exe"]],
"x86_64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-x86_64-dynamic"]],
"x86_64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-aarch64.so"]],
"aarch64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-armv7.so"]],
"arm"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-i586.so"]],
"i386"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-ppc64.so"]],
"ppc64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-ppc64le.so"]],
"ppc64le"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-riscv64.so"]],
"riscv64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-s390x.so"]],
"s390x"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-sparc.so"]],
"sparc"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-win32.dll"]],
"i386"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-win64.dll"]],
"x86_64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-x86_64.so"]],
"x86_64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/initrd-x86_64.img"]],
"x86_64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/initrd-x86_64.img.gz"]],
"x86_64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/bin-x86_64-dynamic.gz"]],
"x86_64"), [];
+ InitISOFS, Always, TestResultString (
+ [["file_architecture"; "/lib-i586.so.xz"]],
"i386"), [];
+ ];
+ shortdesc = "detect the architecture of a binary file";
+ longdesc = "\
+This detects the architecture of the binary F<filename>,
+and returns it if known.
+
+Currently defined architectures are:
+
+=over 4
+
+=item \"aarch64\"
+
+64 bit ARM.
+
+=item \"arm\"
+
+32 bit ARM.
+
+=item \"i386\"
+
+This string is returned for all 32 bit i386, i486, i586, i686 binaries
+irrespective of the precise processor requirements of the binary.
+
+=item \"ia64\"
+
+Intel Itanium.
+
+=item \"ppc\"
+
+32 bit Power PC.
+
+=item \"ppc64\"
+
+64 bit Power PC (big endian).
+
+=item \"ppc64le\"
+
+64 bit Power PC (little endian).
+
+=item \"riscv32\"
+
+=item \"riscv64\"
+
+=item \"riscv128\"
+
+RISC-V 32-, 64- or 128-bit variants.
+
+=item \"s390\"
+
+31 bit IBM S/390.
+
+=item \"s390x\"
+
+64 bit IBM S/390.
+
+=item \"sparc\"
+
+32 bit SPARC.
+
+=item \"sparc64\"
+
+64 bit SPARC V9 and above.
+
+=item \"x86_64\"
+
+64 bit x86-64.
+
+=back
+
+Libguestfs may return other architecture strings in future.
+
+The function works on at least the following types of files:
+
+=over 4
+
+=item *
+
+many types of Un*x and Linux binary
+
+=item *
+
+many types of Un*x and Linux shared library
+
+=item *
+
+Windows Win32 and Win64 binaries
+
+=item *
+
+Windows Win32 and Win64 DLLs
+
+Win32 binaries and DLLs return C<i386>.
+
+Win64 binaries and DLLs return C<x86_64>.
+
+=item *
+
+Linux kernel modules
+
+=item *
+
+Linux new-style initrd images
+
+=item *
+
+some non-x86 Linux vmlinuz kernels
+
+=back
+
+What it can't do currently:
+
+=over 4
+
+=item *
+
+static libraries (libfoo.a)
+
+=item *
+
+Linux old-style initrd as compressed ext2 filesystem (RHEL 3)
+
+=item *
+
+x86 Linux vmlinuz kernels
+
+x86 vmlinuz images (bzImage format) consist of a mix of 16-, 32- and
+compressed code, and are horribly hard to unpack. If you want to find
+the architecture of a kernel, use the architecture of the associated
+initrd or kernel module(s) instead.
+
+=back" };
+
]
diff --git a/generator/proc_nr.ml b/generator/proc_nr.ml
index c7619638a..1b0feae87 100644
--- a/generator/proc_nr.ml
+++ b/generator/proc_nr.ml
@@ -482,6 +482,7 @@ let proc_nr = [
472, "yara_load";
473, "yara_destroy";
474, "internal_yara_scan";
+475, "file_architecture";
]
(* End of list. If adding a new entry, add it at the end of the list
diff --git a/lib/MAX_PROC_NR b/lib/MAX_PROC_NR
index 5f3bb9813..7573eff88 100644
--- a/lib/MAX_PROC_NR
+++ b/lib/MAX_PROC_NR
@@ -1 +1 @@
-474
+475
diff --git a/lib/Makefile.am b/lib/Makefile.am
index 5a1443b62..fab8c4a45 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -89,7 +89,6 @@ libguestfs_la_SOURCES = \
event-string.c \
events.c \
file.c \
- filearch.c \
fuse.c \
guid.c \
handle.c \
@@ -159,7 +158,7 @@ libguestfs_la_LIBADD = \
../common/qemuopts/libqemuopts.la \
../common/structs/libstructs.la \
../common/utils/libutils.la \
- $(PCRE_LIBS) $(MAGIC_LIBS) \
+ $(PCRE_LIBS) \
$(LIBVIRT_LIBS) $(LIBXML2_LIBS) \
$(SELINUX_LIBS) \
$(YAJL_LIBS) \
diff --git a/lib/filearch.c b/lib/filearch.c
deleted file mode 100644
index e1d3daeef..000000000
--- a/lib/filearch.c
+++ /dev/null
@@ -1,362 +0,0 @@
-/* libguestfs
- * Copyright (C) 2010 Red Hat Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2 of the License, or (at your option) any later version.
- *
- * This library 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
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; 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 <inttypes.h>
-#include <unistd.h>
-#include <string.h>
-#include <sys/stat.h>
-#include <sys/wait.h>
-#include <libintl.h>
-
-#include <magic.h>
-
-#include "ignore-value.h"
-
-#include "guestfs.h"
-#include "guestfs-internal.h"
-#include "guestfs-internal-actions.h"
-
-# ifdef HAVE_ATTRIBUTE_CLEANUP
-# define CLEANUP_MAGIC_T_FREE __attribute__((cleanup(cleanup_magic_t_free)))
-
-static void
-cleanup_magic_t_free (void *ptr)
-{
- magic_t m = *(magic_t *) ptr;
-
- if (m)
- magic_close (m);
-}
-
-# else
-# define CLEANUP_MAGIC_T_FREE
-# endif
-
-COMPILE_REGEXP (re_file_elf,
- "ELF (\\d+)-bit (MSB|LSB).*(?:executable|shared
object|relocatable), (.+?),", 0)
-COMPILE_REGEXP (re_elf_ppc64, ".*64.*PowerPC", 0)
-
-/* Convert output from 'file' command on ELF files to the canonical
- * architecture string. Caller must free the result.
- */
-static char *
-canonical_elf_arch (guestfs_h *g,
- const char *bits, const char *endianness,
- const char *elf_arch)
-{
- const char *r;
- char *ret;
-
- if (strstr (elf_arch, "Intel 80386") ||
- strstr (elf_arch, "Intel 80486"))
- r = "i386";
- else if (strstr (elf_arch, "x86-64") ||
- strstr (elf_arch, "AMD x86-64"))
- r = "x86_64";
- else if (strstr (elf_arch, "SPARC32"))
- r = "sparc";
- else if (strstr (elf_arch, "SPARC V9"))
- r = "sparc64";
- else if (strstr (elf_arch, "IA-64"))
- r = "ia64";
- else if (match (g, elf_arch, re_elf_ppc64)) {
- if (strstr (endianness, "MSB"))
- r = "ppc64";
- else if (strstr (endianness, "LSB"))
- r = "ppc64le";
- else {
- error (g, "file_architecture: unknown endianness '%s'",
endianness);
- return NULL;
- }
- }
- else if (strstr (elf_arch, "PowerPC"))
- r = "ppc";
- else if (strstr (elf_arch, "ARM aarch64"))
- r = "aarch64";
- else if (strstr (elf_arch, "ARM"))
- r = "arm";
- else if (strstr (elf_arch, "UCB RISC-V")) {
- ret = safe_asprintf (g, "riscv%s", bits);
- goto no_strdup;
- }
- else if (strstr (elf_arch, "IBM S/390")) {
- if (STREQ (bits, "32"))
- r = "s390";
- else if (STREQ (bits, "64"))
- r = "s390x";
- else {
- error (g, "file_architecture: unknown S/390 bit size: %s",
bits);
- return NULL;
- }
- }
- else
- r = elf_arch;
-
- ret = safe_strdup (g, r);
- no_strdup:
- return ret;
-}
-
-static int
-is_regular_file (const char *filename)
-{
- struct stat statbuf;
-
- return lstat (filename, &statbuf) == 0 && S_ISREG
(statbuf.st_mode);
-}
-
-static char *
-magic_for_file (guestfs_h *g, const char *filename, bool *loading_ok,
- bool *matched)
-{
- int flags;
- CLEANUP_MAGIC_T_FREE magic_t m = NULL;
- const char *line;
- CLEANUP_FREE char *bits = NULL;
- CLEANUP_FREE char *elf_arch = NULL;
- CLEANUP_FREE char *endianness = NULL;
-
- flags = g->verbose ? MAGIC_DEBUG : 0;
- flags |= MAGIC_ERROR | MAGIC_RAW;
-
- if (loading_ok)
- *loading_ok = false;
- if (matched)
- *matched = false;
-
- m = magic_open (flags);
- if (m == NULL) {
- perrorf (g, "magic_open");
- return NULL;
- }
-
- if (magic_load (m, NULL) == -1) {
- perrorf (g, "magic_load: default magic database file");
- return NULL;
- }
-
- line = magic_file (m, filename);
- if (line == NULL) {
- perrorf (g, "magic_file: %s", filename);
- return NULL;
- }
-
- if (loading_ok)
- *loading_ok = true;
-
- if (!match3 (g, line, re_file_elf, &bits, &endianness,
&elf_arch)) {
- error (g, "no re_file_elf match in '%s'", line);
- return NULL;
- }
-
- if (matched)
- *matched = true;
-
- return canonical_elf_arch (g, bits, endianness, elf_arch);
-}
-
-/* Download and uncompress the cpio file to find binaries within. */
-static const char *initrd_binaries[] = {
- "bin/ls",
- "bin/rm",
- "bin/modprobe",
- "sbin/modprobe",
- "bin/sh",
- "bin/bash",
- "bin/dash",
- "bin/nash",
- NULL
-};
-
-static char *
-cpio_arch (guestfs_h *g, const char *file, const char *path)
-{
- CLEANUP_FREE char *tmpdir = guestfs_get_tmpdir (g), *dir = NULL;
- CLEANUP_FREE char *initrd = NULL;
- CLEANUP_CMD_CLOSE struct command *cmd = guestfs_int_new_command (g);
- char *ret = NULL;
- const char *method;
- int64_t size;
- int r;
- size_t i;
-
- if (asprintf (&dir, "%s/libguestfsXXXXXX", tmpdir) == -1) {
- perrorf (g, "asprintf");
- return NULL;
- }
-
- if (strstr (file, "gzip"))
- method = "zcat";
- else if (strstr (file, "bzip2"))
- method = "bzcat";
- else
- method = "cat";
-
- /* Security: Refuse to download initrd if it is huge. */
- size = guestfs_filesize (g, path);
- if (size == -1 || size > 100000000) {
- error (g, _("size of %s unreasonable (%" PRIi64 "
bytes)"),
- path, size);
- goto out;
- }
-
- if (mkdtemp (dir) == NULL) {
- perrorf (g, "mkdtemp");
- goto out;
- }
-
- initrd = safe_asprintf (g, "%s/initrd", dir);
- if (guestfs_download (g, path, initrd) == -1)
- goto out;
-
- /* Construct a command to extract named binaries from the initrd file. */
- guestfs_int_cmd_add_string_unquoted (cmd, "cd ");
- guestfs_int_cmd_add_string_quoted (cmd, dir);
- guestfs_int_cmd_add_string_unquoted (cmd, " && ");
- guestfs_int_cmd_add_string_unquoted (cmd, method);
- guestfs_int_cmd_add_string_unquoted (cmd, " initrd | cpio --quiet
-id");
- for (i = 0; initrd_binaries[i] != NULL; ++i) {
- guestfs_int_cmd_add_string_unquoted (cmd, " ");
- guestfs_int_cmd_add_string_quoted (cmd, initrd_binaries[i]);
- }
-
- r = guestfs_int_cmd_run (cmd);
- if (r == -1)
- goto out;
- if (!WIFEXITED (r) || WEXITSTATUS (r) != 0) {
- guestfs_int_external_command_failed (g, r, "cpio", path);
- goto out;
- }
-
- for (i = 0; initrd_binaries[i] != NULL; ++i) {
- CLEANUP_FREE char *bin - safe_asprintf (g, "%s/%s", dir,
initrd_binaries[i]);
-
- if (is_regular_file (bin)) {
- bool loading_ok, matched;
-
- ret = magic_for_file (g, bin, &loading_ok, &matched);
- if (!loading_ok || matched)
- goto out;
- }
- }
- error (g, "file_architecture: could not determine architecture of cpio
archive");
-
- out:
- guestfs_int_recursive_remove_dir (g, dir);
-
- return ret;
-}
-
-static char *
-compressed_file_arch (guestfs_h *g, const char *path, const char *method)
-{
- CLEANUP_FREE char *tmpdir = guestfs_get_tmpdir (g), *dir = NULL;
- CLEANUP_FREE char *tempfile = NULL, *tempfile_extracted = NULL;
- CLEANUP_CMD_CLOSE struct command *cmd = guestfs_int_new_command (g);
- char *ret = NULL;
- int64_t size;
- int r;
- bool matched;
-
- if (asprintf (&dir, "%s/libguestfsXXXXXX", tmpdir) == -1) {
- perrorf (g, "asprintf");
- return NULL;
- }
-
- /* Security: Refuse to download file if it is huge. */
- size = guestfs_filesize (g, path);
- if (size == -1 || size > 10000000) {
- error (g, _("size of %s unreasonable (%" PRIi64 "
bytes)"),
- path, size);
- goto out;
- }
-
- if (mkdtemp (dir) == NULL) {
- perrorf (g, "mkdtemp");
- goto out;
- }
-
- tempfile = safe_asprintf (g, "%s/file", dir);
- if (guestfs_download (g, path, tempfile) == -1)
- goto out;
-
- tempfile_extracted = safe_asprintf (g, "%s/file_extracted", dir);
-
- /* Construct a command to extract named binaries from the initrd file. */
- guestfs_int_cmd_add_string_unquoted (cmd, method);
- guestfs_int_cmd_add_string_unquoted (cmd, " ");
- guestfs_int_cmd_add_string_quoted (cmd, tempfile);
- guestfs_int_cmd_add_string_unquoted (cmd, " > ");
- guestfs_int_cmd_add_string_quoted (cmd, tempfile_extracted);
-
- r = guestfs_int_cmd_run (cmd);
- if (r == -1)
- goto out;
- if (!WIFEXITED (r) || WEXITSTATUS (r) != 0) {
- guestfs_int_external_command_failed (g, r, method, path);
- goto out;
- }
-
- ret = magic_for_file (g, tempfile_extracted, NULL, &matched);
- if (!matched)
- error (g, "file_architecture: could not determine architecture of
compressed file");
-
- out:
- guestfs_int_recursive_remove_dir (g, dir);
-
- return ret;
-}
-
-char *
-guestfs_impl_file_architecture (guestfs_h *g, const char *path)
-{
- CLEANUP_FREE char *file = NULL;
- CLEANUP_FREE char *bits = NULL;
- CLEANUP_FREE char *elf_arch = NULL;
- CLEANUP_FREE char *endianness = NULL;
- char *ret = NULL;
-
- /* Get the output of the "file" command. Note that because this
- * runs in the daemon, LANG=C so it's in English.
- */
- file = guestfs_file (g, path);
- if (file == NULL)
- return NULL;
-
- if ((match3 (g, file, re_file_elf, &bits, &endianness,
&elf_arch)) != 0)
- ret = canonical_elf_arch (g, bits, endianness, elf_arch);
- else if (strstr (file, "PE32 executable"))
- ret = safe_strdup (g, "i386");
- else if (strstr (file, "PE32+ executable"))
- ret = safe_strdup (g, "x86_64");
- else if (strstr (file, "cpio archive"))
- ret = cpio_arch (g, file, path);
- else if (strstr (file, "gzip compressed data"))
- ret = compressed_file_arch (g, path, "zcat");
- else if (strstr (file, "XZ compressed data"))
- ret = compressed_file_arch (g, path, "xzcat");
- else
- error (g, "file_architecture: unknown architecture: %s", path);
-
- return ret; /* caller frees */
-}
diff --git a/po/POTFILES b/po/POTFILES
index 429c63abf..456cbe73b 100644
--- a/po/POTFILES
+++ b/po/POTFILES
@@ -363,7 +363,6 @@ lib/errors.c
lib/event-string.c
lib/events.c
lib/file.c
-lib/filearch.c
lib/fuse.c
lib/guid.c
lib/handle.c
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 12/23] daemon: Reimplement ‘list_ldm_(volumes|partitions)’ APIs in OCaml.
---
daemon/Makefile.am | 2 ++
daemon/ldm.c | 82 -----------------------------------------------
daemon/ldm.ml | 44 +++++++++++++++++++++++++
daemon/ldm.mli | 20 ++++++++++++
generator/actions_core.ml | 2 ++
5 files changed, 68 insertions(+), 82 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 31cb01b85..f5049516b 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -249,6 +249,7 @@ SOURCES_MLI = \
file.mli \
filearch.mli \
is.mli \
+ ldm.mli \
link.mli \
mount.mli \
mountable.mli \
@@ -269,6 +270,7 @@ SOURCES_ML = \
file.ml \
filearch.ml \
is.ml \
+ ldm.ml \
link.ml \
mount.ml \
parted.ml \
diff --git a/daemon/ldm.c b/daemon/ldm.c
index 609a3e1ec..1bab28989 100644
--- a/daemon/ldm.c
+++ b/daemon/ldm.c
@@ -23,7 +23,6 @@
#include <unistd.h>
#include <sys/types.h>
#include <sys/stat.h>
-#include <glob.h>
#include <string.h>
#include <yajl/yajl_tree.h>
@@ -45,87 +44,6 @@ optgroup_ldm_available (void)
return prog_exists ("ldmtool");
}
-static int
-glob_errfunc (const char *epath, int eerrno)
-{
- fprintf (stderr, "glob: failure reading %s: %s\n", epath, strerror
(eerrno));
- return 1;
-}
-
-static char **
-get_devices (const char *pattern)
-{
- CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
- glob_t devs;
- int err;
- size_t i;
-
- memset (&devs, 0, sizeof devs);
-
- err = glob (pattern, GLOB_ERR, glob_errfunc, &devs);
- if (err == GLOB_NOSPACE) {
- reply_with_error ("glob: returned GLOB_NOSPACE: "
- "rerun with LIBGUESTFS_DEBUG=1");
- goto error;
- } else if (err == GLOB_ABORTED) {
- reply_with_error ("glob: returned GLOB_ABORTED: "
- "rerun with LIBGUESTFS_DEBUG=1");
- goto error;
- }
-
- for (i = 0; i < devs.gl_pathc; ++i) {
- if (add_string (&ret, devs.gl_pathv[i]) == -1)
- goto error;
- }
-
- if (end_stringsbuf (&ret) == -1) goto error;
-
- globfree (&devs);
- return take_stringsbuf (&ret);
-
- error:
- globfree (&devs);
-
- return NULL;
-}
-
-/* All device mapper devices called /dev/mapper/ldm_vol_*. XXX We
- * could tighten this up in future if ldmtool had a way to read these
- * names back after they have been created.
- */
-char **
-do_list_ldm_volumes (void)
-{
- struct stat buf;
-
- /* If /dev/mapper doesn't exist at all, don't give an error. */
- if (stat ("/dev/mapper", &buf) == -1) {
- if (errno == ENOENT)
- return empty_list ();
- reply_with_perror ("/dev/mapper");
- return NULL;
- }
-
- return get_devices ("/dev/mapper/ldm_vol_*");
-}
-
-/* Same as above but /dev/mapper/ldm_part_*. See comment above. */
-char **
-do_list_ldm_partitions (void)
-{
- struct stat buf;
-
- /* If /dev/mapper doesn't exist at all, don't give an error. */
- if (stat ("/dev/mapper", &buf) == -1) {
- if (errno == ENOENT)
- return empty_list ();
- reply_with_perror ("/dev/mapper");
- return NULL;
- }
-
- return get_devices ("/dev/mapper/ldm_part_*");
-}
-
int
do_ldmtool_create_all (void)
{
diff --git a/daemon/ldm.ml b/daemon/ldm.ml
new file mode 100644
index 000000000..f943e3cfd
--- /dev/null
+++ b/daemon/ldm.ml
@@ -0,0 +1,44 @@
+(* 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
+
+open Utils
+
+(* All device mapper devices are called /dev/mapper/ldm_vol_*
+ * or /dev/mapper/ldm_part_*.
+ *
+ * XXX We could tighten this up in future if ldmtool had a way
+ * to read these names back after they have been created.
+ *)
+let rec list_ldm_volumes () = list "ldm_vol_"
+
+and list_ldm_partitions () = list "ldm_part_"
+
+and list prefix + (* If /dev/mapper doesn't exist at all, don't give
an error. *)
+ if not (is_directory "/dev/mapper") then
+ []
+ else (
+ let dir = Sys.readdir "/dev/mapper" in
+ let dir = Array.to_list dir in
+ let dir + List.filter (fun d -> String.is_prefix d prefix) dir in
+ let dir = List.map ((^) "/dev/mapper/") dir in
+ List.sort compare dir
+ )
diff --git a/daemon/ldm.mli b/daemon/ldm.mli
new file mode 100644
index 000000000..789abb0b3
--- /dev/null
+++ b/daemon/ldm.mli
@@ -0,0 +1,20 @@
+(* 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 list_ldm_volumes : unit -> string list
+val list_ldm_partitions : unit -> string list
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index bfd96589e..331a5feb1 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -8114,6 +8114,7 @@ The capabilities set C<cap> should be passed in text
form
{ defaults with
name = "list_ldm_volumes"; added = (1, 20, 0);
style = RStringList (RDevice, "devices"), [], [];
+ impl = OCaml "Ldm.list_ldm_volumes";
optional = Some "ldm";
shortdesc = "list all Windows dynamic disk volumes";
longdesc = "\
@@ -8124,6 +8125,7 @@ device names." };
{ defaults with
name = "list_ldm_partitions"; added = (1, 20, 0);
style = RStringList (RDevice, "devices"), [], [];
+ impl = OCaml "Ldm.list_ldm_partitions";
optional = Some "ldm";
shortdesc = "list all Windows dynamic disk partitions";
longdesc = "\
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 13/23] daemon: Reimplement ‘lvs’ API in OCaml.
---
daemon/Makefile.am | 2 +
daemon/lvm.c | 151 ----------------------------------------------
daemon/lvm.ml | 98 ++++++++++++++++++++++++++++++
daemon/lvm.mli | 19 ++++++
generator/actions_core.ml | 1 +
5 files changed, 120 insertions(+), 151 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index f5049516b..2e723bfc8 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -251,6 +251,7 @@ SOURCES_MLI = \
is.mli \
ldm.mli \
link.mli \
+ lvm.mli \
mount.mli \
mountable.mli \
parted.mli \
@@ -272,6 +273,7 @@ SOURCES_ML = \
is.ml \
ldm.ml \
link.ml \
+ lvm.ml \
mount.ml \
parted.ml \
realpath.ml \
diff --git a/daemon/lvm.c b/daemon/lvm.c
index af2582448..4026c4f92 100644
--- a/daemon/lvm.c
+++ b/daemon/lvm.c
@@ -101,89 +101,6 @@ convert_lvm_output (char *out, const char *prefix)
return take_stringsbuf (&ret);
}
-/* Filter a colon-separated output of
- * lvs -o lv_attr,vg_name,lv_name
- * removing thin layouts, and building the device path as we expect it.
- *
- * This is used only when lvm has no -S.
- */
-static char **
-filter_convert_old_lvs_output (char *out)
-{
- char *p, *pend;
- CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
-
- p = out;
- while (p) {
- size_t len;
- char *saveptr;
- char *lv_attr, *vg_name, *lv_name;
-
- pend = strchr (p, '\n'); /* Get the next line of output. */
- if (pend) {
- *pend = '\0';
- pend++;
- }
-
- while (*p && c_isspace (*p)) /* Skip any leading whitespace. */
- p++;
-
- /* Sigh, skip trailing whitespace too. "pvs", I'm looking at
you. */
- len = strlen (p)-1;
- while (*p && c_isspace (p[len]))
- p[len--] = '\0';
-
- if (!*p) { /* Empty line? Skip it. */
- skip_line:
- p = pend;
- continue;
- }
-
- lv_attr = strtok_r (p, ":", &saveptr);
- if (!lv_attr)
- goto skip_line;
-
- vg_name = strtok_r (NULL, ":", &saveptr);
- if (!vg_name)
- goto skip_line;
-
- lv_name = strtok_r (NULL, ":", &saveptr);
- if (!lv_name)
- goto skip_line;
-
- /* Ignore thin layouts (RHBZ#1278878). */
- if (lv_attr[0] == 't')
- goto skip_line;
-
- /* Ignore activationskip (RHBZ#1306666). */
- if (strlen (lv_attr) >= 10 && lv_attr[9] == 'k')
- goto skip_line;
-
- /* Ignore "unknown device" message (RHBZ#1054761). */
- if (STRNEQ (p, "unknown device")) {
- char buf[256];
-
- snprintf (buf, sizeof buf, "/dev/%s/%s", vg_name, lv_name);
- if (add_string (&ret, buf) == -1) {
- free (out);
- return NULL;
- }
- }
-
- p = pend;
- }
-
- free (out);
-
- if (ret.size > 0)
- sort_strings (ret.argv, ret.size);
-
- if (end_stringsbuf (&ret) == -1)
- return NULL;
-
- return take_stringsbuf (&ret);
-}
-
char **
do_pvs (void)
{
@@ -220,74 +137,6 @@ do_vgs (void)
return convert_lvm_output (out, NULL);
}
-/* Check whether lvs has -S to filter its output.
- * It is available only in lvm2 >= 2.02.107.
- */
-static int
-test_lvs_has_S_opt (void)
-{
- static int result = -1;
- if (result != -1)
- return result;
-
- CLEANUP_FREE char *out = NULL;
- CLEANUP_FREE char *err = NULL;
-
- int r = command (&out, &err, "lvm", "lvs",
"--help", NULL);
- if (r == -1) {
- reply_with_error ("lvm lvs --help: %s", err);
- return -1;
- }
-
- if (strstr (out, "-S") == NULL)
- result = 0;
- else
- result = 1;
-
- return result;
-}
-
-char **
-do_lvs (void)
-{
- char *out;
- CLEANUP_FREE char *err = NULL;
- int r;
- const int has_S = test_lvs_has_S_opt ();
-
- if (has_S < 0)
- return NULL;
-
- if (has_S > 0) {
- r = command (&out, &err,
- "lvm", "lvs",
- "-o", "vg_name,lv_name",
- "-S", "lv_role=public &&
lv_skip_activation!=yes",
- "--noheadings",
- "--separator", "/", NULL);
- if (r == -1) {
- reply_with_error ("%s", err);
- free (out);
- return NULL;
- }
-
- return convert_lvm_output (out, "/dev/");
- } else {
- r = command (&out, &err,
- "lvm", "lvs",
- "-o", "lv_attr,vg_name,lv_name",
- "--noheadings",
- "--separator", ":", NULL);
- if (r == -1) {
- reply_with_error ("%s", err);
- free (out);
- return NULL;
- }
-
- return filter_convert_old_lvs_output (out);
- }
-}
-
/* These were so complex to implement that I ended up auto-generating
* the code. That code is in stubs.c, and it is generated as usual
* by generator.ml.
diff --git a/daemon/lvm.ml b/daemon/lvm.ml
new file mode 100644
index 000000000..4a9156dad
--- /dev/null
+++ b/daemon/lvm.ml
@@ -0,0 +1,98 @@
+(* 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 Std_utils
+
+open Utils
+
+(* Check whether lvs has -S to filter its output.
+ * It is available only in lvm2 >= 2.02.107.
+ *)
+let lvs_has_S_opt = lazy (
+ let out = command "lvm" ["lvs"; "--help"] in
+ String.find out "-S" >= 0
+)
+
+let rec lvs () + let has_S = Lazy.force lvs_has_S_opt in
+ if has_S then (
+ let out = command "lvm" ["lvs";
+ "-o"; "vg_name,lv_name";
+ "-S"; "lv_role=public &&
lv_skip_activation!=yes";
+ "--noheadings";
+ "--separator"; "/"] in
+ convert_lvm_output ~prefix:"/dev/" out
+ )
+ else (
+ let out = command "lvm" ["lvs";
+ "-o";
"lv_attr,vg_name,lv_name";
+ "--noheadings";
+ "--separator"; ":"] in
+ filter_convert_old_lvs_output out
+ )
+
+and convert_lvm_output ?prefix out + let lines = String.nsplit "\n"
out in
+
+ (* Skip leading and trailing ("pvs", I'm looking at you)
whitespace. *)
+ let lines = List.map String.trim lines in
+
+ (* Skip empty lines. *)
+ let lines = List.filter ((<>) "") lines in
+
+ (* Ignore "unknown device" message (RHBZ#1054761). *)
+ let lines = List.filter ((<>) "unknown device") lines in
+
+ (* Add a prefix? *)
+ let lines + match prefix with
+ | None -> lines
+ | Some prefix -> List.map ((^) prefix) lines in
+
+ (* Sort and return. *)
+ List.sort compare lines
+
+(* Filter a colon-separated output of
+ * lvs -o lv_attr,vg_name,lv_name
+ * removing thin layouts, and building the device path as we expect it.
+ *
+ * This is used only when lvm has no -S.
+ *)
+and filter_convert_old_lvs_output out + let lines = String.nsplit
"\n" out in
+ let lines = List.map String.trim lines in
+ let lines = List.filter ((<>) "") lines in
+ let lines = List.filter ((<>) "unknown device") lines in
+
+ let lines = filter_map (
+ fun line ->
+ match String.nsplit ":" line with
+ | [ lv_attr; vg_name; lv_name ] ->
+ (* Ignore thin layouts (RHBZ#1278878). *)
+ if String.length lv_attr > 0 && lv_attr.[0] = 't'
then None
+ (* Ignore activationskip (RHBZ#1306666). *)
+ else if String.length lv_attr > 9 && lv_attr.[9] =
'k' then None
+ else
+ Some (sprintf "/dev/%s/%s" vg_name lv_name)
+ | _ ->
+ None
+ ) lines in
+
+ List.sort compare lines
diff --git a/daemon/lvm.mli b/daemon/lvm.mli
new file mode 100644
index 000000000..f254728cb
--- /dev/null
+++ b/daemon/lvm.mli
@@ -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.
+ *)
+
+val lvs : unit -> string list
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 331a5feb1..f6f006eee 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -1732,6 +1732,7 @@ See also C<guestfs_vgs_full>." };
{ defaults with
name = "lvs"; added = (0, 0, 4);
style = RStringList (RDevice, "logvols"), [], [];
+ impl = OCaml "Lvm.lvs";
optional = Some "lvm2";
tests = [
InitBasicFSonLVM, Always, TestResult (
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 14/23] daemon: Reimplement ‘list_md_devices’ API in OCaml.
---
daemon/Makefile.am | 2 +
daemon/md.c | 125 ++++++++++++----------------------------------
daemon/md.ml | 48 ++++++++++++++++++
daemon/md.mli | 19 +++++++
generator/actions_core.ml | 1 +
5 files changed, 101 insertions(+), 94 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 2e723bfc8..873f6b394 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -252,6 +252,7 @@ SOURCES_MLI = \
ldm.mli \
link.mli \
lvm.mli \
+ md.mli \
mount.mli \
mountable.mli \
parted.mli \
@@ -274,6 +275,7 @@ SOURCES_ML = \
ldm.ml \
link.ml \
lvm.ml \
+ md.ml \
mount.ml \
parted.ml \
realpath.ml \
diff --git a/daemon/md.c b/daemon/md.c
index 246e38150..55461b95a 100644
--- a/daemon/md.c
+++ b/daemon/md.c
@@ -24,7 +24,6 @@
#include <inttypes.h>
#include <unistd.h>
#include <fcntl.h>
-#include <glob.h>
#ifdef HAVE_LINUX_RAID_MD_U_H
#include <sys/ioctl.h>
@@ -32,6 +31,8 @@
#include <linux/raid/md_u.h>
#endif /* HAVE_LINUX_RAID_MD_U_H */
+#include <caml/mlvalues.h>
+
#include "daemon.h"
#include "actions.h"
#include "optgroups.h"
@@ -43,6 +44,35 @@ optgroup_mdadm_available (void)
return prog_exists ("mdadm");
}
+/* Check if 'dev' is a real RAID device, because in the case where md
+ * is linked directly into the kernel (not a module), /dev/md0 is
+ * sometimes created. This is called from OCaml function
+ * Md.list_md_devices.
+ */
+extern value guestfs_int_daemon_is_raid_device (value devicev);
+
+/* NB: This is a "noalloc" call. */
+value
+guestfs_int_daemon_is_raid_device (value devv)
+{
+ const char *dev = String_val (devv);
+ int ret = 1;
+
+#if defined(HAVE_LINUX_RAID_MD_U_H) && defined(GET_ARRAY_INFO)
+ int fd;
+ mdu_array_info_t array;
+
+ fd = open (dev, O_RDONLY);
+ if (fd >= 0) {
+ if (ioctl (fd, GET_ARRAY_INFO, &array) == -1 && errno ==
ENODEV)
+ ret = 0;
+ close (fd);
+ }
+#endif
+
+ return Val_bool (ret);
+}
+
static size_t
count_bits (uint64_t bitmap)
{
@@ -186,99 +216,6 @@ do_md_create (const char *name, char *const *devices,
#pragma GCC diagnostic pop
#endif
-static int
-glob_errfunc (const char *epath, int eerrno)
-{
- fprintf (stderr, "glob: failure reading %s: %s\n", epath, strerror
(eerrno));
- return 1;
-}
-
-/* Check if 'dev' is a real RAID device, because in the case where md
- * is linked directly into the kernel (not a module), /dev/md0 is
- * sometimes created.
- */
-static int
-is_raid_device (const char *dev)
-{
- int ret = 1;
-
-#if defined(HAVE_LINUX_RAID_MD_U_H) && defined(GET_ARRAY_INFO)
- int fd;
- mdu_array_info_t array;
-
- fd = open (dev, O_RDONLY);
- if (fd >= 0) {
- if (ioctl (fd, GET_ARRAY_INFO, &array) == -1 && errno ==
ENODEV)
- ret = 0;
- close (fd);
- }
-#endif
-
- return ret;
-}
-
-char **
-do_list_md_devices (void)
-{
- CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
- glob_t mds;
-
- memset (&mds, 0, sizeof mds);
-
-#define PREFIX "/sys/block/md"
-#define SUFFIX "/md"
-
- /* Look for directories under /sys/block matching md[0-9]*
- * As an additional check, we also make sure they have a md subdirectory.
- */
- const int err = glob (PREFIX "[0-9]*" SUFFIX, GLOB_ERR,
glob_errfunc, &mds);
- if (err == GLOB_NOSPACE) {
- reply_with_error ("glob: returned GLOB_NOSPACE: "
- "rerun with LIBGUESTFS_DEBUG=1");
- goto error;
- } else if (err == GLOB_ABORTED) {
- reply_with_error ("glob: returned GLOB_ABORTED: "
- "rerun with LIBGUESTFS_DEBUG=1");
- goto error;
- }
-
- for (size_t i = 0; i < mds.gl_pathc; i++) {
- size_t len;
- char *dev, *n;
-
- len = strlen (mds.gl_pathv[i]) - strlen (PREFIX) - strlen (SUFFIX);
-
-#define DEV "/dev/md"
- dev = malloc (strlen (DEV) + len + 1);
- if (NULL == dev) {
- reply_with_perror ("malloc");
- goto error;
- }
-
- n = dev;
- n = mempcpy (n, DEV, strlen (DEV));
- n = mempcpy (n, &mds.gl_pathv[i][strlen (PREFIX)], len);
- *n = '\0';
-
- if (!is_raid_device (dev)) {
- free (dev);
- continue;
- }
-
- if (add_string_nodup (&ret, dev) == -1) goto error;
- }
-
- if (end_stringsbuf (&ret) == -1) goto error;
- globfree (&mds);
-
- return take_stringsbuf (&ret);
-
- error:
- globfree (&mds);
-
- return NULL;
-}
-
char **
do_md_detail (const char *md)
{
diff --git a/daemon/md.ml b/daemon/md.ml
new file mode 100644
index 000000000..caf87cf8f
--- /dev/null
+++ b/daemon/md.ml
@@ -0,0 +1,48 @@
+(* 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 Std_utils
+
+open Utils
+
+external is_raid_device : string -> bool +
"guestfs_int_daemon_is_raid_device" "noalloc"
+
+let re_md = Str.regexp "^md[0-9]+$"
+
+let list_md_devices () + (* Look for directories under /sys/block matching
md[0-9]+
+ * As an additional check, we also make sure they have a md subdirectory.
+ *)
+ let devs = Sys.readdir "/sys/block" in
+ let devs = Array.to_list devs in
+ let devs = List.filter (fun d -> Str.string_match re_md d 0) devs in
+ let devs = List.filter (
+ fun d -> is_directory (sprintf "/sys/block/%s/md" d)
+ ) devs in
+
+ (* Construct the equivalent /dev/md[0-9]+ device names. *)
+ let devs = List.map ((^) "/dev/") devs in
+
+ (* Check they are really RAID devices. *)
+ let devs = List.filter is_raid_device devs in
+
+ (* Return the list sorted. *)
+ sort_device_names devs
diff --git a/daemon/md.mli b/daemon/md.mli
new file mode 100644
index 000000000..56b6ea65e
--- /dev/null
+++ b/daemon/md.mli
@@ -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.
+ *)
+
+val list_md_devices : unit -> string list
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index f6f006eee..140ba6c1b 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -6632,6 +6632,7 @@ If not set, this defaults to C<raid1>.
{ defaults with
name = "list_md_devices"; added = (1, 15, 4);
style = RStringList (RDevice, "devices"), [], [];
+ impl = OCaml "Md.list_md_devices";
shortdesc = "list Linux md (RAID) devices";
longdesc = "\
List all Linux md devices." };
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 15/23] daemon: Reimplement ‘btrfs_subvolume_list’ and ‘btrfs_subvolume_get_default’ in OCaml.
---
daemon/Makefile.am | 2 +
daemon/btrfs.c | 175 ----------------------------------------------
daemon/btrfs.ml | 127 +++++++++++++++++++++++++++++++++
daemon/btrfs.mli | 26 +++++++
generator/actions_core.ml | 2 +
5 files changed, 157 insertions(+), 175 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 873f6b394..9971a45a7 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -243,6 +243,7 @@ guestfsd_CFLAGS = \
# https://caml.inria.fr/pub/docs/manual-ocaml/intfc.html
SOURCES_MLI = \
blkid.mli \
+ btrfs.mli \
chroot.mli \
sysroot.mli \
devsparts.mli \
@@ -268,6 +269,7 @@ SOURCES_ML = \
mountable.ml \
chroot.ml \
blkid.ml \
+ btrfs.ml \
devsparts.ml \
file.ml \
filearch.ml \
diff --git a/daemon/btrfs.c b/daemon/btrfs.c
index 00c9b3c75..f11902b21 100644
--- a/daemon/btrfs.c
+++ b/daemon/btrfs.c
@@ -33,11 +33,6 @@
#include "c-ctype.h"
#include "ignore-value.h"
-COMPILE_REGEXP (re_btrfs_subvolume_list,
- "ID\\s+(\\d+).*\\s"
- "top level\\s+(\\d+).*\\s"
- "path\\s(.*)",
- 0)
COMPILE_REGEXP (re_btrfs_balance_status, "Balance on '.*' is
(.*)", 0)
int
@@ -475,137 +470,6 @@ umount (char *fs_buf, const mountable_t *fs)
return 0;
}
-guestfs_int_btrfssubvolume_list *
-do_btrfs_subvolume_list (const mountable_t *fs)
-{
- CLEANUP_FREE_STRING_LIST char **lines = NULL;
- size_t i = 0;
- const size_t MAX_ARGS = 64;
- const char *argv[MAX_ARGS];
-
- /* Execute 'btrfs subvolume list <fs>', and split the output
into lines */
- {
- char *fs_buf = mount (fs);
-
- if (!fs_buf)
- return NULL;
-
- ADD_ARG (argv, i, "btrfs");
- ADD_ARG (argv, i, "subvolume");
- ADD_ARG (argv, i, "list");
- ADD_ARG (argv, i, fs_buf);
- ADD_ARG (argv, i, NULL);
-
- CLEANUP_FREE char *out = NULL, *errout = NULL;
- int r = commandv (&out, &errout, argv);
-
- if (umount (fs_buf, fs) != 0)
- return NULL;
-
- if (r == -1) {
- CLEANUP_FREE char *fs_desc = mountable_to_string (fs);
- if (fs_desc == NULL) {
- fprintf (stderr, "malloc: %m");
- }
- reply_with_error ("%s: %s", fs_desc ? fs_desc :
"malloc", errout);
- return NULL;
- }
-
- lines = split_lines (out);
- if (!lines) return NULL;
- }
-
- /* Output is:
- *
- * ID 256 gen 30 top level 5 path test1
- * ID 257 gen 30 top level 5 path dir/test2
- * ID 258 gen 30 top level 5 path test3
- *
- * "ID <n>" is the subvolume ID.
- * "gen <n>" is the generation when the root was created or
last
- * updated.
- * "top level <n>" is the top level subvolume ID.
- * "path <str>" is the subvolume path, relative to the top of
the
- * filesystem.
- *
- * Note that the order that each of the above is fixed, but
- * different versions of btrfs may display different sets of data.
- * Specifically, older versions of btrfs do not display gen.
- */
-
- guestfs_int_btrfssubvolume_list *ret = NULL;
-
- const size_t nr_subvolumes = guestfs_int_count_strings (lines);
-
- ret = malloc (sizeof *ret);
- if (!ret) {
- reply_with_perror ("malloc");
- return NULL;
- }
-
- ret->guestfs_int_btrfssubvolume_list_len = nr_subvolumes;
- ret->guestfs_int_btrfssubvolume_list_val - calloc (nr_subvolumes,
sizeof (struct guestfs_int_btrfssubvolume));
- if (ret->guestfs_int_btrfssubvolume_list_val == NULL) {
- reply_with_perror ("calloc");
- goto error;
- }
-
- for (i = 0; i < nr_subvolumes; ++i) {
- /* To avoid allocations, reuse the 'line' buffer to store the
- * path. Thus we don't need to free 'line', since it will be
- * freed by the calling (XDR) code.
- */
- char *line = lines[i];
-#define N_MATCHES 4
- int ovector[N_MATCHES * 3];
-
- if (pcre_exec (re_btrfs_subvolume_list, NULL, line, strlen (line), 0, 0,
- ovector, N_MATCHES * 3) < 0)
-#undef N_MATCHES
- {
- unexpected_output:
- reply_with_error ("unexpected output from 'btrfs subvolume list'
command: %s", line);
- goto error;
- }
-
- struct guestfs_int_btrfssubvolume *this -
&ret->guestfs_int_btrfssubvolume_list_val[i];
-
-#if __WORDSIZE == 64
-#define XSTRTOU64 xstrtoul
-#else
-#define XSTRTOU64 xstrtoull
-#endif
-
- if (XSTRTOU64 (line + ovector[2], NULL, 10,
- &this->btrfssubvolume_id, NULL) != LONGINT_OK)
- goto unexpected_output;
- if (XSTRTOU64 (line + ovector[4], NULL, 10,
- &this->btrfssubvolume_top_level_id, NULL) !=
LONGINT_OK)
- goto unexpected_output;
-
-#undef XSTRTOU64
-
- this->btrfssubvolume_path - strndup (line + ovector[6], ovector[7]
- ovector[6]);
- if (this->btrfssubvolume_path == NULL)
- goto error;
- }
-
- return ret;
-
- error:
- if (ret->guestfs_int_btrfssubvolume_list_val) {
- for (i = 0; i < nr_subvolumes; ++i)
- free
(ret->guestfs_int_btrfssubvolume_list_val[i].btrfssubvolume_path);
- free (ret->guestfs_int_btrfssubvolume_list_val);
- }
- free (ret);
-
- return NULL;
-}
-
int
do_btrfs_subvolume_set_default (int64_t id, const char *fs)
{
@@ -641,45 +505,6 @@ do_btrfs_subvolume_set_default (int64_t id, const char *fs)
return 0;
}
-int64_t
-do_btrfs_subvolume_get_default (const mountable_t *fs)
-{
- const size_t MAX_ARGS = 64;
- const char *argv[MAX_ARGS];
- size_t i = 0;
- char *fs_buf = NULL;
- CLEANUP_FREE char *err = NULL;
- CLEANUP_FREE char *out = NULL;
- int r;
- int64_t ret = -1;
-
- fs_buf = mount (fs);
- if (fs_buf == NULL)
- goto error;
-
- ADD_ARG (argv, i, "btrfs");
- ADD_ARG (argv, i, "subvolume");
- ADD_ARG (argv, i, "get-default");
- ADD_ARG (argv, i, fs_buf);
- ADD_ARG (argv, i, NULL);
-
- r = commandv (&out, &err, argv);
- if (r == -1) {
- reply_with_error ("%s: %s", fs_buf, err);
- goto error;
- }
- if (sscanf (out, "ID %" SCNi64, &ret) != 1) {
- reply_with_error ("%s: could not parse subvolume id: %s",
argv[0], out);
- ret = -1;
- goto error;
- }
-
- error:
- if (fs_buf && umount (fs_buf, fs) != 0)
- return -1;
- return ret;
-}
-
int
do_btrfs_filesystem_sync (const char *fs)
{
diff --git a/daemon/btrfs.ml b/daemon/btrfs.ml
new file mode 100644
index 000000000..fc02abefa
--- /dev/null
+++ b/daemon/btrfs.ml
@@ -0,0 +1,127 @@
+(* 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 Scanf
+open Unix
+
+open Std_utils
+open Unix_utils
+
+open Mountable
+open Utils
+
+include Structs
+
+(* In order to examine subvolumes, quota and other things, the btrfs
+ * filesystem has to be mounted. However we're passed a mountable
+ * in these cases, so we must mount the filesystem. But we cannot
+ * mount it under the sysroot, as something else might be mounted
+ * there so this function mounts the filesystem on a temporary
+ * directory and ensures it is always unmounted afterwards.
+ *)
+let rec with_mounted mountable f + let _with_mounted mount_cmd f + let
tmpdir = Mkdtemp.temp_dir "btrfs" in
+
+ (* This is the cleanup function which is called to unmount and
+ * remove the temporary directory. This is called on error and
+ * ordinary exit paths.
+ *)
+ let finally () + ignore (Sys.command (sprintf "umount %s"
(quote tmpdir)));
+ rmdir tmpdir
+ in
+
+ protect ~finally ~f:(fun () -> mount_cmd tmpdir; f tmpdir)
+ in
+
+ match mountable.m_type with
+ | MountablePath ->
+ (* This corner-case happens for Mountable_or_Path parameters, where
+ * a path was supplied by the caller. The path (the m_device
+ * field) is relative to the sysroot.
+ *)
+ f (Sysroot.sysroot_path mountable.m_device)
+
+ | MountableDevice ->
+ let cmd tmpdir + ignore (command "mount"
[mountable.m_device; tmpdir]) in
+ _with_mounted cmd f
+
+ | MountableBtrfsVol subvol ->
+ let cmd tmpdir + ignore (command "mount" ["-o";
"subvol=" ^ subvol (* XXX quoting? *);
+ mountable.m_device; tmpdir]) in
+ _with_mounted cmd f
+
+let re_btrfs_subvolume_list + Str.regexp ("ID[ \t]+\\([0-9]+\\).*[
\t]" ^
+ "top level[ \t]+\\([0-9]+\\).*[ \t]" ^
+ "path[ \t]+\\(.*\\)")
+
+let btrfs_subvolume_list mountable + (* Execute 'btrfs subvolume list
<fs>', and split the output into lines *)
+ let lines + with_mounted mountable (
+ fun mp -> command "btrfs" ["subvolume";
"list"; mp]
+ ) in
+ let lines = String.nsplit "\n" lines in
+ let lines = List.filter ((<>) "") lines in
+
+ (* Output is:
+ *
+ * ID 256 gen 30 top level 5 path test1
+ * ID 257 gen 30 top level 5 path dir/test2
+ * ID 258 gen 30 top level 5 path test3
+ *
+ * "ID <n>" is the subvolume ID.
+ * "gen <n>" is the generation when the root was created or
last
+ * updated.
+ * "top level <n>" is the top level subvolume ID.
+ * "path <str>" is the subvolume path, relative to the top of
the
+ * filesystem.
+ *
+ * Note that the order that each of the above is fixed, but
+ * different versions of btrfs may display different sets of data.
+ * Specifically, older versions of btrfs do not display gen.
+ *)
+ List.map (
+ fun line ->
+ if Str.string_match re_btrfs_subvolume_list line 0 then (
+ let id = Int64.of_string (Str.matched_group 1 line)
+ and top_level_id = Int64.of_string (Str.matched_group 2 line)
+ and path = Str.matched_group 3 line in
+
+ {
+ btrfssubvolume_id = id;
+ btrfssubvolume_top_level_id = top_level_id;
+ btrfssubvolume_path = path
+ }
+ )
+ else
+ failwithf "unexpected output from 'btrfs subvolume list'
command: %s"
+ line
+ ) lines
+
+let btrfs_subvolume_get_default mountable + let out + with_mounted
mountable (
+ fun mp -> command "btrfs" ["subvolume";
"get-default"; mp]
+ ) in
+ sscanf out "ID %Ld" identity
diff --git a/daemon/btrfs.mli b/daemon/btrfs.mli
new file mode 100644
index 000000000..55a38e42d
--- /dev/null
+++ b/daemon/btrfs.mli
@@ -0,0 +1,26 @@
+(* 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.
+ *)
+
+type btrfssubvolume = {
+ btrfssubvolume_id : int64;
+ btrfssubvolume_top_level_id : int64;
+ btrfssubvolume_path : string;
+}
+
+val btrfs_subvolume_list : Mountable.t -> btrfssubvolume list
+val btrfs_subvolume_get_default : Mountable.t -> int64
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 140ba6c1b..bd3c21d3b 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -7304,6 +7304,7 @@ created subvolume will be added to." };
{ defaults with
name = "btrfs_subvolume_list"; added = (1, 17, 35);
style = RStructList ("subvolumes", "btrfssubvolume"),
[String (Mountable_or_Path, "fs")], [];
+ impl = OCaml "Btrfs.btrfs_subvolume_list";
optional = Some "btrfs"; camel_name =
"BTRFSSubvolumeList";
test_excuse = "tested in tests/btrfs";
shortdesc = "list btrfs snapshots and subvolumes";
@@ -8783,6 +8784,7 @@ This uses the L<blockdev(8)> command." };
{ defaults with
name = "btrfs_subvolume_get_default"; added = (1, 29, 17);
style = RInt64 "id", [String (Mountable_or_Path,
"fs")], [];
+ impl = OCaml "Btrfs.btrfs_subvolume_get_default";
optional = Some "btrfs"; camel_name =
"BTRFSSubvolumeGetDefault";
tests = [
InitPartition, Always, TestResult (
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 16/23] daemon: Reimplement ‘list_filesystems’ API in the daemon, in OCaml.
Move the list_filesystems API into the daemon, reimplementing it in
OCaml. Since this API makes many other API calls, it runs a lot
faster in the daemon.
---
daemon/Makefile.am | 2 +
daemon/ldm.ml | 2 +
daemon/ldm.mli | 2 +
daemon/listfs.ml | 159 ++++++++++++++++++++++++++++++
daemon/listfs.mli | 19 ++++
daemon/lvm.ml | 2 +
daemon/lvm.mli | 2 +
docs/C_SOURCE_FILES | 1 -
generator/actions_core.ml | 75 +++++++-------
generator/proc_nr.ml | 1 +
lib/MAX_PROC_NR | 2 +-
lib/Makefile.am | 1 -
lib/listfs.c | 246 ----------------------------------------------
13 files changed, 228 insertions(+), 286 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 9971a45a7..e3517ca15 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -252,6 +252,7 @@ SOURCES_MLI = \
is.mli \
ldm.mli \
link.mli \
+ listfs.mli \
lvm.mli \
md.mli \
mount.mli \
@@ -280,6 +281,7 @@ SOURCES_ML = \
md.ml \
mount.ml \
parted.ml \
+ listfs.ml \
realpath.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/ldm.ml b/daemon/ldm.ml
index f943e3cfd..9720a6c8a 100644
--- a/daemon/ldm.ml
+++ b/daemon/ldm.ml
@@ -20,6 +20,8 @@ open Std_utils
open Utils
+let available = Optgroups.ldm_available
+
(* All device mapper devices are called /dev/mapper/ldm_vol_*
* or /dev/mapper/ldm_part_*.
*
diff --git a/daemon/ldm.mli b/daemon/ldm.mli
index 789abb0b3..e6edfabd8 100644
--- a/daemon/ldm.mli
+++ b/daemon/ldm.mli
@@ -16,5 +16,7 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
+val available : unit -> bool
+
val list_ldm_volumes : unit -> string list
val list_ldm_partitions : unit -> string list
diff --git a/daemon/listfs.ml b/daemon/listfs.ml
new file mode 100644
index 000000000..610a1ea78
--- /dev/null
+++ b/daemon/listfs.ml
@@ -0,0 +1,159 @@
+(* 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 Std_utils
+
+let rec list_filesystems () + let has_lvm2 = Lvm.available () in
+ let has_ldm = Ldm.available () in
+
+ let devices = Devsparts.list_devices () in
+ let partitions = Devsparts.list_partitions () in
+ let mds = Md.list_md_devices () in
+
+ (* Look to see if any devices directly contain filesystems
+ * (RHBZ#590167). However vfs-type will fail to tell us anything
+ * useful about devices which just contain partitions, so we also
+ * get the list of partitions and exclude the corresponding devices
+ * by using part-to-dev.
+ *)
+ let devices_containing_partitions = List.fold_left (
+ fun set part ->
+ StringSet.add (Devsparts.part_to_dev part) set
+ ) StringSet.empty partitions in
+ let devices = List.filter (
+ fun dev ->
+ not (StringSet.mem dev devices_containing_partitions)
+ ) devices in
+
+ (* Use vfs-type to check for filesystems on devices. *)
+ let ret = filter_map check_with_vfs_type devices in
+
+ (* Use vfs-type to check for filesystems on partitions, but
+ * ignore MBR partition type 42 used by LDM.
+ *)
+ let ret + ret @
+ filter_map (
+ fun part ->
+ if not has_ldm || not (is_mbr_partition_type_42 part) then
+ check_with_vfs_type part
+ else
+ None (* ignore type 42 *)
+ ) partitions in
+
+ (* Use vfs-type to check for filesystems on md devices. *)
+ let ret = ret @ filter_map check_with_vfs_type mds in
+
+ (* LVM. *)
+ let ret + if has_lvm2 then (
+ let lvs = Lvm.lvs () in
+ (* Use vfs-type to check for filesystems on LVs. *)
+ ret @ filter_map check_with_vfs_type lvs
+ )
+ else ret in
+
+ (* LDM. *)
+ let ret + if has_ldm then (
+ let ldmvols = Ldm.list_ldm_volumes () in
+ let ldmparts = Ldm.list_ldm_partitions () in
+ (* Use vfs-type to check for filesystems on Windows dynamic disks. *)
+ ret @
+ filter_map check_with_vfs_type ldmvols @
+ filter_map check_with_vfs_type ldmparts
+ )
+ else ret in
+
+ List.flatten ret
+
+(* Use vfs-type to check for a filesystem of some sort of [device].
+ * Returns [Some [device, vfs_type; ...]] if found (there may be
+ * multiple devices found in the case of btrfs), else [None] if nothing
+ * is found.
+ *)
+and check_with_vfs_type device + let mountable = Mountable.of_device device in
+ let vfs_type + try Blkid.vfs_type mountable
+ with exn ->
+ if verbose () then
+ eprintf "check_with_vfs_type: %s: %s\n"
+ device (Printexc.to_string exn);
+ "" in
+
+ if vfs_type = "" then
+ Some [mountable, "unknown"]
+
+ (* Ignore all "*_member" strings. In libblkid these are returned
+ * for things which are members of some RAID or LVM set, most
+ * importantly "LVM2_member" which is a PV.
+ *)
+ else if String.is_suffix vfs_type "_member" then
+ None
+
+ (* Ignore LUKS-encrypted partitions. These are also containers, as above. *)
+ else if vfs_type = "crypto_LUKS" then
+ None
+
+ (* A single btrfs device can turn into many volumes. *)
+ else if vfs_type = "btrfs" then (
+ let vols = Btrfs.btrfs_subvolume_list mountable in
+
+ (* Filter out the default subvolume. You can access that by
+ * simply mounting the whole device, so we will add the whole
+ * device at the beginning of the returned list instead.
+ *)
+ let default_volume = Btrfs.btrfs_subvolume_get_default mountable in
+ let vols + List.filter (
+ fun { Btrfs.btrfssubvolume_id = id } -> id <> default_volume
+ ) vols in
+
+ Some (
+ (mountable, vfs_type) (* whole device = default volume *)
+ :: List.map (
+ fun { Btrfs.btrfssubvolume_path = path } ->
+ let mountable = Mountable.of_btrfsvol device path in
+ (mountable, "btrfs")
+ ) vols
+ )
+ )
+
+ else
+ Some [mountable, vfs_type]
+
+(* We should ignore partitions that have MBR type byte 0x42, because
+ * these are members of a Windows dynamic disk group. Trying to read
+ * them will cause errors (RHBZ#887520). Assuming that libguestfs was
+ * compiled with ldm support, we'll get the filesystems on these later.
+ *)
+and is_mbr_partition_type_42 partition + try
+ let partnum = Devsparts.part_to_partnum partition in
+ let device = Devsparts.part_to_dev partition in
+ let mbr_id = Parted.part_get_mbr_id device partnum in
+ mbr_id = 0x42
+ with exn ->
+ if verbose () then
+ eprintf "is_mbr_partition_type_42: %s: %s\n"
+ partition (Printexc.to_string exn);
+ false
diff --git a/daemon/listfs.mli b/daemon/listfs.mli
new file mode 100644
index 000000000..69958da77
--- /dev/null
+++ b/daemon/listfs.mli
@@ -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.
+ *)
+
+val list_filesystems : unit -> (Mountable.t * string) list
diff --git a/daemon/lvm.ml b/daemon/lvm.ml
index 4a9156dad..0d1dc55b5 100644
--- a/daemon/lvm.ml
+++ b/daemon/lvm.ml
@@ -22,6 +22,8 @@ open Std_utils
open Utils
+let available = Optgroups.lvm2_available
+
(* Check whether lvs has -S to filter its output.
* It is available only in lvm2 >= 2.02.107.
*)
diff --git a/daemon/lvm.mli b/daemon/lvm.mli
index f254728cb..1cf61ecfb 100644
--- a/daemon/lvm.mli
+++ b/daemon/lvm.mli
@@ -16,4 +16,6 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
+val available : unit -> bool
+
val lvs : unit -> string list
diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index 7ac6716cd..b4f085699 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -325,7 +325,6 @@ lib/launch.c
lib/libvirt-auth.c
lib/libvirt-domain.c
lib/libvirt-is-version.c
-lib/listfs.c
lib/lpj.c
lib/match.c
lib/mountable.c
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index bd3c21d3b..d5946b3f5 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -209,43 +209,6 @@ If the mountable does not represent a btrfs subvolume, then
this function fails and the C<errno> is set to C<EINVAL>." };
{ defaults with
- name = "list_filesystems"; added = (1, 5, 15);
- style = RHashtable (RMountable, RPlainString, "fses"), [], [];
- shortdesc = "list filesystems";
- longdesc = "\
-This inspection command looks for filesystems on partitions,
-block devices and logical volumes, returning a list of C<mountables>
-containing filesystems and their type.
-
-The return value is a hash, where the keys are the devices
-containing filesystems, and the values are the filesystem types.
-For example:
-
- \"/dev/sda1\" => \"ntfs\"
- \"/dev/sda2\" => \"ext2\"
- \"/dev/vg_guest/lv_root\" => \"ext4\"
- \"/dev/vg_guest/lv_swap\" => \"swap\"
-
-The key is not necessarily a block device. It may also be an opaque
-‘mountable’ string which can be passed to C<guestfs_mount>.
-
-The value can have the special value \"unknown\", meaning the
-content of the device is undetermined or empty.
-\"swap\" means a Linux swap partition.
-
-This command runs other libguestfs commands, which might include
-C<guestfs_mount> and C<guestfs_umount>, and therefore you should
-use this soon after launch and only when nothing is mounted.
-
-Not all of the filesystems returned will be mountable. In
-particular, swap partitions are returned in the list. Also
-this command does not check that each filesystem
-found is valid and mountable, and some filesystems might
-be mountable but require special options. Filesystems may
-not all belong to a single logical operating system
-(use C<guestfs_inspect_os> to look for OSes)." };
-
- { defaults with
name = "add_drive"; added = (0, 0, 3);
style = RErr, [String (PlainString, "filename")], [OBool
"readonly"; OString "format"; OString "iface";
OString "name"; OString "label"; OString
"protocol"; OStringList "server"; OString
"username"; OString "secret"; OString "cachemode";
OString "discard"; OBool "copyonread"];
once_had_no_optargs = true;
@@ -9635,4 +9598,42 @@ initrd or kernel module(s) instead.
=back" };
+ { defaults with
+ name = "list_filesystems"; added = (1, 5, 15);
+ style = RHashtable (RMountable, RPlainString, "fses"), [], [];
+ impl = OCaml "Listfs.list_filesystems";
+ shortdesc = "list filesystems";
+ longdesc = "\
+This inspection command looks for filesystems on partitions,
+block devices and logical volumes, returning a list of C<mountables>
+containing filesystems and their type.
+
+The return value is a hash, where the keys are the devices
+containing filesystems, and the values are the filesystem types.
+For example:
+
+ \"/dev/sda1\" => \"ntfs\"
+ \"/dev/sda2\" => \"ext2\"
+ \"/dev/vg_guest/lv_root\" => \"ext4\"
+ \"/dev/vg_guest/lv_swap\" => \"swap\"
+
+The key is not necessarily a block device. It may also be an opaque
+‘mountable’ string which can be passed to C<guestfs_mount>.
+
+The value can have the special value \"unknown\", meaning the
+content of the device is undetermined or empty.
+\"swap\" means a Linux swap partition.
+
+This command runs other libguestfs commands, which might include
+C<guestfs_mount> and C<guestfs_umount>, and therefore you should
+use this soon after launch and only when nothing is mounted.
+
+Not all of the filesystems returned will be mountable. In
+particular, swap partitions are returned in the list. Also
+this command does not check that each filesystem
+found is valid and mountable, and some filesystems might
+be mountable but require special options. Filesystems may
+not all belong to a single logical operating system
+(use C<guestfs_inspect_os> to look for OSes)." };
+
]
diff --git a/generator/proc_nr.ml b/generator/proc_nr.ml
index 1b0feae87..dec02f5fa 100644
--- a/generator/proc_nr.ml
+++ b/generator/proc_nr.ml
@@ -483,6 +483,7 @@ let proc_nr = [
473, "yara_destroy";
474, "internal_yara_scan";
475, "file_architecture";
+476, "list_filesystems";
]
(* End of list. If adding a new entry, add it at the end of the list
diff --git a/lib/MAX_PROC_NR b/lib/MAX_PROC_NR
index 7573eff88..b86395733 100644
--- a/lib/MAX_PROC_NR
+++ b/lib/MAX_PROC_NR
@@ -1 +1 @@
-475
+476
diff --git a/lib/Makefile.am b/lib/Makefile.am
index fab8c4a45..cab03107f 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -109,7 +109,6 @@ libguestfs_la_SOURCES = \
launch-unix.c \
libvirt-auth.c \
libvirt-domain.c \
- listfs.c \
lpj.c \
match.c \
mountable.c \
diff --git a/lib/listfs.c b/lib/listfs.c
deleted file mode 100644
index 60aff3305..000000000
--- a/lib/listfs.c
+++ /dev/null
@@ -1,246 +0,0 @@
-/* libguestfs
- * Copyright (C) 2010 Red Hat Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2 of the License, or (at your option) any later version.
- *
- * This library 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
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; 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 <string.h>
-
-#include "guestfs.h"
-#include "guestfs-internal.h"
-#include "guestfs-internal-actions.h"
-#include "structs-cleanups.h"
-
-/* List filesystems.
- *
- * The current implementation just uses guestfs_vfs_type and doesn't
- * try mounting anything, but we reserve the right in future to try
- * mounting filesystems.
- */
-
-static void remove_from_list (char **list, const char *item);
-static int check_with_vfs_type (guestfs_h *g, const char *dev, struct
stringsbuf *sb);
-static int is_mbr_partition_type_42 (guestfs_h *g, const char *partition);
-
-char **
-guestfs_impl_list_filesystems (guestfs_h *g)
-{
- size_t i;
- DECLARE_STRINGSBUF (ret);
-
- const char *lvm2[] = { "lvm2", NULL };
- const int has_lvm2 = guestfs_feature_available (g, (char **) lvm2);
- const char *ldm[] = { "ldm", NULL };
- const int has_ldm = guestfs_feature_available (g, (char **) ldm);
-
- CLEANUP_FREE_STRING_LIST char **devices = NULL;
- CLEANUP_FREE_STRING_LIST char **partitions = NULL;
- CLEANUP_FREE_STRING_LIST char **mds = NULL;
- CLEANUP_FREE_STRING_LIST char **lvs = NULL;
- CLEANUP_FREE_STRING_LIST char **ldmvols = NULL;
- CLEANUP_FREE_STRING_LIST char **ldmparts = NULL;
-
- /* Look to see if any devices directly contain filesystems
- * (RHBZ#590167). However vfs-type will fail to tell us anything
- * useful about devices which just contain partitions, so we also
- * get the list of partitions and exclude the corresponding devices
- * by using part-to-dev.
- */
- devices = guestfs_list_devices (g);
- if (devices == NULL) goto error;
- partitions = guestfs_list_partitions (g);
- if (partitions == NULL) goto error;
- mds = guestfs_list_md_devices (g);
- if (mds == NULL) goto error;
-
- for (i = 0; partitions[i] != NULL; ++i) {
- CLEANUP_FREE char *dev = guestfs_part_to_dev (g, partitions[i]);
- if (dev)
- remove_from_list (devices, dev);
- }
-
- /* Use vfs-type to check for filesystems on devices. */
- for (i = 0; devices[i] != NULL; ++i)
- if (check_with_vfs_type (g, devices[i], &ret) == -1)
- goto error;
-
- /* Use vfs-type to check for filesystems on partitions. */
- for (i = 0; partitions[i] != NULL; ++i) {
- if (has_ldm == 0 || ! is_mbr_partition_type_42 (g, partitions[i])) {
- if (check_with_vfs_type (g, partitions[i], &ret) == -1)
- goto error;
- }
- }
-
- /* Use vfs-type to check for filesystems on md devices. */
- for (i = 0; mds[i] != NULL; ++i)
- if (check_with_vfs_type (g, mds[i], &ret) == -1)
- goto error;
-
- if (has_lvm2 > 0) {
- /* Use vfs-type to check for filesystems on LVs. */
- lvs = guestfs_lvs (g);
- if (lvs == NULL) goto error;
-
- for (i = 0; lvs[i] != NULL; ++i)
- if (check_with_vfs_type (g, lvs[i], &ret) == -1)
- goto error;
- }
-
- if (has_ldm > 0) {
- /* Use vfs-type to check for filesystems on Windows dynamic disks. */
- ldmvols = guestfs_list_ldm_volumes (g);
- if (ldmvols == NULL) goto error;
-
- for (i = 0; ldmvols[i] != NULL; ++i)
- if (check_with_vfs_type (g, ldmvols[i], &ret) == -1)
- goto error;
-
- ldmparts = guestfs_list_ldm_partitions (g);
- if (ldmparts == NULL) goto error;
-
- for (i = 0; ldmparts[i] != NULL; ++i)
- if (check_with_vfs_type (g, ldmparts[i], &ret) == -1)
- goto error;
- }
-
- /* Finish off the list and return it. */
- guestfs_int_end_stringsbuf (g, &ret);
- return ret.argv;
-
- error:
- guestfs_int_free_stringsbuf (&ret);
- return NULL;
-}
-
-/* If 'item' occurs in 'list', remove and free it. */
-static void
-remove_from_list (char **list, const char *item)
-{
- size_t i;
-
- for (i = 0; list[i] != NULL; ++i)
- if (STREQ (list[i], item)) {
- free (list[i]);
- for (; list[i+1] != NULL; ++i)
- list[i] = list[i+1];
- list[i] = NULL;
- return;
- }
-}
-
-/* Use vfs-type to look for a filesystem of some sort on 'dev'.
- * Apart from some types which we ignore, add the result to the
- * 'ret' string list.
- */
-static int
-check_with_vfs_type (guestfs_h *g, const char *device, struct stringsbuf *sb)
-{
- const char *v;
- CLEANUP_FREE char *vfs_type = NULL;
-
- guestfs_push_error_handler (g, NULL, NULL);
- vfs_type = guestfs_vfs_type (g, device);
- guestfs_pop_error_handler (g);
-
- if (!vfs_type)
- v = "unknown";
- else if (STREQ (vfs_type, ""))
- v = "unknown";
- else if (STREQ (vfs_type, "btrfs")) {
- CLEANUP_FREE_BTRFSSUBVOLUME_LIST struct guestfs_btrfssubvolume_list *vols -
guestfs_btrfs_subvolume_list (g, device);
-
- if (vols == NULL)
- return -1;
-
- const int64_t default_volume - guestfs_btrfs_subvolume_get_default (g,
device);
-
- for (size_t i = 0; i < vols->len; i++) {
- struct guestfs_btrfssubvolume *this = &vols->val[i];
-
- /* Ignore the default subvolume. We get it by simply mounting
- * the whole device of this btrfs filesystem.
- */
- if (this->btrfssubvolume_id == (uint64_t) default_volume)
- continue;
-
- guestfs_int_add_sprintf (g, sb,
- "btrfsvol:%s/%s",
- device, this->btrfssubvolume_path);
- guestfs_int_add_string (g, sb, "btrfs");
- }
-
- v = vfs_type;
- }
- else {
- /* Ignore all "*_member" strings. In libblkid these are returned
- * for things which are members of some RAID or LVM set, most
- * importantly "LVM2_member" which is a PV.
- */
- const size_t n = strlen (vfs_type);
- if (n >= 7 && STREQ (&vfs_type[n-7], "_member"))
- return 0;
-
- /* Ignore LUKS-encrypted partitions. These are also containers. */
- if (STREQ (vfs_type, "crypto_LUKS"))
- return 0;
-
- v = vfs_type;
- }
-
- guestfs_int_add_string (g, sb, device);
- guestfs_int_add_string (g, sb, v);
-
- return 0;
-}
-
-/* We should ignore partitions that have MBR type byte 0x42, because
- * these are members of a Windows dynamic disk group. Trying to read
- * them will cause errors (RHBZ#887520). Assuming that libguestfs was
- * compiled with ldm support, we'll get the filesystems on these later.
- */
-static int
-is_mbr_partition_type_42 (guestfs_h *g, const char *partition)
-{
- CLEANUP_FREE char *device = NULL;
- int partnum;
- int mbr_id;
- int ret = 0;
-
- guestfs_push_error_handler (g, NULL, NULL);
-
- partnum = guestfs_part_to_partnum (g, partition);
- if (partnum == -1)
- goto out;
-
- device = guestfs_part_to_dev (g, partition);
- if (device == NULL)
- goto out;
-
- mbr_id = guestfs_part_get_mbr_id (g, device, partnum);
-
- ret = mbr_id == 0x42;
-
- out:
- guestfs_pop_error_handler (g);
-
- return ret;
-}
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 17/23] daemon: Reimplement ‘part_list’ API in OCaml.
---
daemon/parted.c | 56 -----------------------------------------------
daemon/parted.ml | 56 +++++++++++++++++++++++++++++++++++++++++++++++
daemon/parted.mli | 8 +++++++
generator/actions_core.ml | 1 +
4 files changed, 65 insertions(+), 56 deletions(-)
diff --git a/daemon/parted.c b/daemon/parted.c
index b788ed72a..3ad1ba147 100644
--- a/daemon/parted.c
+++ b/daemon/parted.c
@@ -383,62 +383,6 @@ do_part_get_parttype (const char *device)
return r;
}
-guestfs_int_partition_list *
-do_part_list (const char *device)
-{
- CLEANUP_FREE char *out = print_partition_table (device, true);
- if (!out)
- return NULL;
-
- CLEANUP_FREE_STRING_LIST char **lines = split_lines (out);
-
- if (!lines)
- return NULL;
-
- guestfs_int_partition_list *r;
-
- /* lines[0] is "BYT;", lines[1] is the device line which we ignore,
- * lines[2..] are the partitions themselves. Count how many.
- */
- size_t nr_rows = 0, row;
- for (row = 2; lines[row] != NULL; ++row)
- ++nr_rows;
-
- r = malloc (sizeof *r);
- if (r == NULL) {
- reply_with_perror ("malloc");
- return NULL;
- }
- r->guestfs_int_partition_list_len = nr_rows;
- r->guestfs_int_partition_list_val - malloc (nr_rows * sizeof
(guestfs_int_partition));
- if (r->guestfs_int_partition_list_val == NULL) {
- reply_with_perror ("malloc");
- goto error2;
- }
-
- /* Now parse the lines. */
- size_t i;
- for (i = 0, row = 2; lines[row] != NULL; ++i, ++row) {
- if (sscanf (lines[row], "%d:%" SCNi64 "B:%" SCNi64
"B:%" SCNi64 "B",
- &r->guestfs_int_partition_list_val[i].part_num,
- &r->guestfs_int_partition_list_val[i].part_start,
- &r->guestfs_int_partition_list_val[i].part_end,
- &r->guestfs_int_partition_list_val[i].part_size) != 4) {
- reply_with_error ("could not parse row from output of parted print
command: %s", lines[row]);
- goto error3;
- }
- }
-
- return r;
-
- error3:
- free (r->guestfs_int_partition_list_val);
- error2:
- free (r);
- return NULL;
-}
-
int
do_part_get_bootable (const char *device, int partnum)
{
diff --git a/daemon/parted.ml b/daemon/parted.ml
index 6be41cf66..da31ab5c6 100644
--- a/daemon/parted.ml
+++ b/daemon/parted.ml
@@ -22,6 +22,8 @@ open Std_utils
open Utils
+include Structs
+
(* Test if [sfdisk] is recent enough to have [--part-type], to be used
* instead of [--print-id] and [--change-id].
*)
@@ -53,3 +55,57 @@ let part_get_mbr_id device partnum
(* It's printed in hex, possibly with a leading space. *)
sscanf out " %x" identity
+
+(* This is not equivalent to print_partition_table in the C code, as
+ * it only deals with the ‘-m’ option output, and it partially parses
+ * that. If we convert other functions that don't use the ‘-m’ version
+ * we'll have to refactor this. XXX
+ *)
+let print_partition_table_machine_readable device + udev_settle ();
+
+ let args = ref [] in
+ push_back args "-m";
+ push_back args "-s";
+ push_back args "--";
+ push_back args device;
+ push_back args "unit";
+ push_back args "b";
+ push_back args "print";
+
+ let out + try command "parted" !args
+ with
+ (* Translate "unrecognised disk label" into an errno code. *)
+ Failure str when String.find str "unrecognised disk label"
>= 0 ->
+ raise (Unix.Unix_error (Unix.EINVAL, "parted", device ^
": " ^ str)) in
+
+ udev_settle ();
+
+ (* Split the output into lines. *)
+ let out = String.trim out in
+ let lines = String.nsplit "\n" out in
+
+ (* lines[0] is "BYT;", lines[1] is the device line which we ignore,
+ * lines[2..] are the partitions themselves.
+ *)
+ match lines with
+ | "BYT;" :: _ :: lines -> lines
+ | [] | [_] ->
+ failwith "too few rows of output from 'parted print'
command"
+ | _ ->
+ failwith "did not see 'BYT;' magic value in 'parted
print' command"
+
+let part_list device + let lines = print_partition_table_machine_readable
device in
+
+ List.map (
+ fun line ->
+ try sscanf line "%d:%LdB:%LdB:%LdB"
+ (fun num start end_ size ->
+ { part_num = Int32.of_int num;
+ part_start = start; part_end = end_; part_size = size })
+ with Scan_failure err ->
+ failwithf "could not parse row from output of 'parted
print' command: %s: %s"
+ line err
+ ) lines
diff --git a/daemon/parted.mli b/daemon/parted.mli
index 33eb6d30d..057d7e8c7 100644
--- a/daemon/parted.mli
+++ b/daemon/parted.mli
@@ -16,4 +16,12 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
+type partition = {
+ part_num : int32;
+ part_start : int64;
+ part_end : int64;
+ part_size : int64;
+}
+
val part_get_mbr_id : string -> int -> int
+val part_list : string -> partition list
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index d5946b3f5..b1e2559e0 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -5039,6 +5039,7 @@ table. This works on C<gpt> but not on C<mbr>
partitions." };
{ defaults with
name = "part_list"; added = (1, 0, 78);
style = RStructList ("partitions", "partition"),
[String (Device, "device")], [];
+ impl = OCaml "Parted.part_list";
tests = [] (* XXX Add a regression test for this. *);
shortdesc = "list partitions on a device";
longdesc = "\
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 18/23] daemon: Reimplement ‘findfs_uuid’ and ‘findfs_label’ APIs in OCaml.
This also reimplements the lv_canonical function in OCaml. We cannot
call the original C function because it calls reply_with_perror which
would break the OCaml bindings.
---
daemon/Makefile.am | 3 +-
daemon/findfs.c | 92 -----------------------------------------------
daemon/findfs.ml | 56 +++++++++++++++++++++++++++++
daemon/findfs.mli | 20 +++++++++++
daemon/lvm.ml | 28 +++++++++++++++
daemon/lvm.mli | 10 ++++++
docs/C_SOURCE_FILES | 1 -
generator/actions_core.ml | 2 ++
8 files changed, 118 insertions(+), 94 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index e3517ca15..eb8bbb152 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -95,7 +95,6 @@ guestfsd_SOURCES = \
ext2.c \
fallocate.c \
file.c \
- findfs.c \
fill.c \
find.c \
format.c \
@@ -249,6 +248,7 @@ SOURCES_MLI = \
devsparts.mli \
file.mli \
filearch.mli \
+ findfs.mli \
is.mli \
ldm.mli \
link.mli \
@@ -278,6 +278,7 @@ SOURCES_ML = \
ldm.ml \
link.ml \
lvm.ml \
+ findfs.ml \
md.ml \
mount.ml \
parted.ml \
diff --git a/daemon/findfs.c b/daemon/findfs.c
deleted file mode 100644
index f44a60088..000000000
--- a/daemon/findfs.c
+++ /dev/null
@@ -1,92 +0,0 @@
-/* libguestfs - the guestfsd daemon
- * Copyright (C) 2010 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 <string.h>
-#include <unistd.h>
-
-#include "daemon.h"
-#include "actions.h"
-
-static char *
-findfs (const char *tag, const char *label_or_uuid)
-{
- char *out;
- CLEANUP_FREE char *err = NULL;
- CLEANUP_FREE char *arg = NULL;
- int r;
- size_t len;
-
- /* Kill the cache file, forcing blkid to reread values from the
- * original filesystems. In blkid there is a '-p' option which is
- * supposed to do this, but (a) it doesn't work and (b) that option
- * is not supported in RHEL 5.
- */
- unlink ("/etc/blkid/blkid.tab");
- unlink ("/run/blkid/blkid.tab");
-
- if (asprintf (&arg, "%s=%s", tag, label_or_uuid) == -1) {
- reply_with_perror ("asprintf");
- return NULL;
- }
-
- r = command (&out, &err, "findfs", arg, NULL);
- if (r == -1) {
- reply_with_error ("%s", err);
- free (out);
- return NULL;
- }
-
- /* Trim trailing \n if present. */
- len = strlen (out);
- if (len > 0 && out[len-1] == '\n')
- out[len-1] = '\0';
-
- if (STRPREFIX (out, "/dev/mapper/") || STRPREFIX (out,
"/dev/dm-")) {
- char *canonical;
- r = lv_canonical (out, &canonical);
- if (r == -1) {
- free (out);
- return NULL;
- }
- if (r == 1) {
- free (out);
- out = canonical;
- }
- /* Ignore the case where r == 0. /dev/mapper does not correspond
- * to an LV, so the best we can do is just return it as-is.
- */
- }
-
- return out; /* caller frees */
-}
-
-char *
-do_findfs_uuid (const char *uuid)
-{
- return findfs ("UUID", uuid);
-}
-
-char *
-do_findfs_label (const char *label)
-{
- return findfs ("LABEL", label);
-}
diff --git a/daemon/findfs.ml b/daemon/findfs.ml
new file mode 100644
index 000000000..8acb72928
--- /dev/null
+++ b/daemon/findfs.ml
@@ -0,0 +1,56 @@
+(* 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 Utils
+
+let rec findfs_uuid uuid + findfs "UUID" uuid
+and findfs_label label + findfs "LABEL"label
+
+and findfs tag str + (* Kill the cache file, forcing blkid to reread values
from the
+ * original filesystems. In blkid there is a '-p' option which is
+ * supposed to do this, but (a) it doesn't work and (b) that option
+ * is not supported in RHEL 5.
+ *)
+ (try unlink "/etc/blkid/blkid.tab" with Unix_error _ -> ());
+ (try unlink "/run/blkid/blkid.tab" with Unix_error _ -> ());
+
+ let out = command "findfs" [ sprintf "%s=%s" tag str ] in
+
+ (* Trim trailing \n if present. *)
+ let out = String.trim out in
+
+ if String.is_prefix out "/dev/mapper/" ||
+ String.is_prefix out "/dev/dm-" then (
+ match Lvm.lv_canonical out with
+ | None ->
+ (* Ignore the case where 'out' doesn't appear to be an LV.
+ * The best we can do is return the original as-is.
+ *)
+ out
+ | Some out -> out
+ )
+ else
+ out
diff --git a/daemon/findfs.mli b/daemon/findfs.mli
new file mode 100644
index 000000000..acef0395c
--- /dev/null
+++ b/daemon/findfs.mli
@@ -0,0 +1,20 @@
+(* 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 findfs_uuid : string -> string
+val findfs_label : string -> string
diff --git a/daemon/lvm.ml b/daemon/lvm.ml
index 0d1dc55b5..4210c2fb3 100644
--- a/daemon/lvm.ml
+++ b/daemon/lvm.ml
@@ -16,6 +16,7 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
+open Unix
open Printf
open Std_utils
@@ -98,3 +99,30 @@ and filter_convert_old_lvs_output out ) lines in
List.sort compare lines
+
+(* Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0
+ * to a canonical one.
+ *
+ * This is harder than it should be. A LV device like /dev/VG/LV is
+ * really a symlink to a device-mapper device like /dev/dm-0. However
+ * at the device-mapper (kernel) level, nothing is really known about
+ * LVM (a userspace concept). Therefore we use a convoluted method to
+ * determine this, by listing out known LVs and checking whether the
+ * rdev (major/minor) of the device we are passed matches any of them.
+ *
+ * Note use of 'stat' instead of 'lstat' so that symlinks are
fully
+ * resolved.
+ *)
+let lv_canonical device + let stat1 = stat device in
+ let lvs = lvs () in
+ try
+ Some (
+ List.find (
+ fun lv ->
+ let stat2 = stat lv in
+ stat1.st_rdev = stat2.st_rdev
+ ) lvs
+ )
+ with
+ | Not_found -> None
diff --git a/daemon/lvm.mli b/daemon/lvm.mli
index 1cf61ecfb..7cde16ebb 100644
--- a/daemon/lvm.mli
+++ b/daemon/lvm.mli
@@ -19,3 +19,13 @@
val available : unit -> bool
val lvs : unit -> string list
+
+val lv_canonical : string -> string option
+(** Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0
+ to a canonical one.
+
+ On error this raises an exception. There are two possible non-error
+ return cases:
+
+ Some lv = conversion was successful, returning the canonical LV
+ None = input path was not an LV, it could not be made canonical *)
diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index b4f085699..d720f43ff 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -104,7 +104,6 @@ daemon/fallocate.c
daemon/file.c
daemon/fill.c
daemon/find.c
-daemon/findfs.c
daemon/format.c
daemon/fs-min-size.c
daemon/fsck.c
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index b1e2559e0..0a967f76d 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -5746,6 +5746,7 @@ returns true iff this is the case." };
{ defaults with
name = "findfs_uuid"; added = (1, 5, 3);
style = RString (RDevice, "device"), [String (PlainString,
"uuid")], [];
+ impl = OCaml "Findfs.findfs_uuid";
shortdesc = "find a filesystem by UUID";
longdesc = "\
This command searches the filesystems and returns the one
@@ -5757,6 +5758,7 @@ To find the UUID of a filesystem, use
C<guestfs_vfs_uuid>." };
{ defaults with
name = "findfs_label"; added = (1, 5, 3);
style = RString (RDevice, "device"), [String (PlainString,
"label")], [];
+ impl = OCaml "Findfs.findfs_label";
shortdesc = "find a filesystem by label";
longdesc = "\
This command searches the filesystems and returns the one
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 19/23] daemon: Reimplement ‘nr_devices’ API in OCaml.
---
daemon/devsparts.c | 15 ---------------
daemon/devsparts.ml | 2 ++
daemon/devsparts.mli | 2 ++
generator/actions_core.ml | 1 +
4 files changed, 5 insertions(+), 15 deletions(-)
diff --git a/daemon/devsparts.c b/daemon/devsparts.c
index 1aacb8e16..12e779326 100644
--- a/daemon/devsparts.c
+++ b/daemon/devsparts.c
@@ -54,21 +54,6 @@ do_device_index (const char *device)
return ret;
}
-int
-do_nr_devices (void)
-{
- size_t i;
- CLEANUP_FREE_STRING_LIST char **devices = do_list_devices ();
-
- if (devices == NULL)
- return -1;
-
- for (i = 0; devices[i] != NULL; ++i)
- ;
-
- return (int) i;
-}
-
#define GUESTFSDIR "/dev/disk/guestfs"
char **
diff --git a/daemon/devsparts.ml b/daemon/devsparts.ml
index 43093aba8..86963899f 100644
--- a/daemon/devsparts.ml
+++ b/daemon/devsparts.ml
@@ -89,6 +89,8 @@ and add_partitions dev let parts = List.filter (fun part
-> String.is_prefix part dev) parts in
List.map ((^) "/dev/") parts
+let nr_devices () = List.length (list_devices ())
+
let part_to_dev part let dev, part = split_device_partition part in
if part = 0 then
diff --git a/daemon/devsparts.mli b/daemon/devsparts.mli
index 4dfaa86e6..8be47e752 100644
--- a/daemon/devsparts.mli
+++ b/daemon/devsparts.mli
@@ -19,6 +19,8 @@
val list_devices : unit -> string list
val list_partitions : unit -> string list
+val nr_devices : unit -> int
+
val part_to_dev : string -> string
val part_to_partnum : string -> int
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 0a967f76d..db1411ff8 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -7432,6 +7432,7 @@ See also C<guestfs_list_devices>,
C<guestfs_part_to_dev>." };
{ defaults with
name = "nr_devices"; added = (1, 19, 15);
+ impl = OCaml "Devsparts.nr_devices";
style = RInt "nrdisks", [], [];
tests = [
InitEmpty, Always, TestResult (
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 20/23] daemon: Reimplement ‘md_detail’ API in OCaml.
---
daemon/md.c | 66 -----------------------------------------------
daemon/md.ml | 34 ++++++++++++++++++++++++
daemon/md.mli | 1 +
generator/actions_core.ml | 1 +
4 files changed, 36 insertions(+), 66 deletions(-)
diff --git a/daemon/md.c b/daemon/md.c
index 55461b95a..973418285 100644
--- a/daemon/md.c
+++ b/daemon/md.c
@@ -216,72 +216,6 @@ do_md_create (const char *name, char *const *devices,
#pragma GCC diagnostic pop
#endif
-char **
-do_md_detail (const char *md)
-{
- size_t i;
- int r;
-
- CLEANUP_FREE char *out = NULL, *err = NULL;
- CLEANUP_FREE_STRING_LIST char **lines = NULL;
-
- CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
-
- const char *mdadm[] = { "mdadm", "-D",
"--export", md, NULL };
- r = commandv (&out, &err, mdadm);
- if (r == -1) {
- reply_with_error ("%s", err);
- return NULL;
- }
-
- /* Split the command output into lines */
- lines = split_lines (out);
- if (lines == NULL)
- return NULL;
-
- /* Parse the output of mdadm -D --export:
- * MD_LEVEL=raid1
- * MD_DEVICES=2
- * MD_METADATA=1.0
- * MD_UUID=cfa81b59:b6cfbd53:3f02085b:58f4a2e1
- * MD_NAME=localhost.localdomain:0
- */
- for (i = 0; lines[i] != NULL; ++i) {
- char *line = lines[i];
-
- /* Skip blank lines (shouldn't happen) */
- if (line[0] == '\0') continue;
-
- /* Split the line in 2 at the equals sign */
- char *eq = strchr (line, '=');
- if (eq) {
- *eq = '\0'; eq++;
-
- /* Remove the MD_ prefix from the key and translate the remainder to
lower
- * case */
- if (STRPREFIX (line, "MD_")) {
- line += 3;
- for (char *j = line; *j != '\0'; j++) {
- *j = c_tolower (*j);
- }
- }
-
- /* Add the key/value pair to the output */
- if (add_string (&ret, line) == -1 ||
- add_string (&ret, eq) == -1) return NULL;
- } else {
- /* Ignore lines with no equals sign (shouldn't happen). Log to stderr
so
- * it will show up in LIBGUESTFS_DEBUG. */
- fprintf (stderr, "md-detail: unexpected mdadm output ignored:
%s", line);
- }
- }
-
- if (end_stringsbuf (&ret) == -1)
- return NULL;
-
- return take_stringsbuf (&ret);
-}
-
int
do_md_stop (const char *md)
{
diff --git a/daemon/md.ml b/daemon/md.ml
index caf87cf8f..1fd00ebb8 100644
--- a/daemon/md.ml
+++ b/daemon/md.ml
@@ -46,3 +46,37 @@ let list_md_devices ()
(* Return the list sorted. *)
sort_device_names devs
+
+let md_detail md + let out = command "mdadm" ["-D";
"--export"; md] in
+
+ (* Split the command output into lines. *)
+ let out = String.trim out in
+ let lines = String.nsplit "\n" out in
+ let lines = List.filter ((<>) "") lines in
+
+ (* Parse the output of mdadm -D --export:
+ * MD_LEVEL=raid1
+ * MD_DEVICES=2
+ * MD_METADATA=1.0
+ * MD_UUID=cfa81b59:b6cfbd53:3f02085b:58f4a2e1
+ * MD_NAME=localhost.localdomain:0
+ *)
+ List.map (
+ fun line ->
+ (* Split the line at the equals sign. *)
+ let key, value = String.split "=" line in
+
+ (* Remove the MD_ prefix from the key and translate the
+ * remainder to lower case.
+ *)
+ let key + if String.is_prefix key "MD_" then
+ String.sub key 3 (String.length key - 3)
+ else
+ key in
+ let key = String.lowercase_ascii key in
+
+ (* Add the key/value pair to the output. *)
+ (key, value)
+ ) lines
diff --git a/daemon/md.mli b/daemon/md.mli
index 56b6ea65e..8f0c79a7f 100644
--- a/daemon/md.mli
+++ b/daemon/md.mli
@@ -17,3 +17,4 @@
*)
val list_md_devices : unit -> string list
+val md_detail : string -> (string * string) list
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index db1411ff8..070a1c641 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -6606,6 +6606,7 @@ List all Linux md devices." };
{ defaults with
name = "md_detail"; added = (1, 15, 6);
style = RHashtable (RPlainString, RPlainString, "info"), [String
(Device, "md")], [];
+ impl = OCaml "Md.md_detail";
optional = Some "mdadm";
shortdesc = "obtain metadata for an MD device";
longdesc = "\
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 21/23] daemon: Reimplement ‘realpath’ API in OCaml.
---
daemon/Makefile.am | 1 -
daemon/realpath.c | 50 -----------------------------------------------
daemon/realpath.ml | 4 ++++
daemon/realpath.mli | 1 +
docs/C_SOURCE_FILES | 1 -
generator/actions_core.ml | 1 +
6 files changed, 6 insertions(+), 52 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index eb8bbb152..1f7cb2277 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -140,7 +140,6 @@ guestfsd_SOURCES = \
pingdaemon.c \
proto.c \
readdir.c \
- realpath.c \
rename.c \
rsync.c \
scrub.c \
diff --git a/daemon/realpath.c b/daemon/realpath.c
deleted file mode 100644
index f9d22d28d..000000000
--- a/daemon/realpath.c
+++ /dev/null
@@ -1,50 +0,0 @@
-/* libguestfs - the guestfsd daemon
- * 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.
- */
-
-#include <config.h>
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <unistd.h>
-#include <fcntl.h>
-#include <limits.h>
-#include <sys/types.h>
-#include <dirent.h>
-
-#include "cloexec.h"
-
-#include "daemon.h"
-#include "optgroups.h"
-#include "actions.h"
-
-char *
-do_realpath (const char *path)
-{
- char *ret;
-
- CHROOT_IN;
- ret = realpath (path, NULL);
- CHROOT_OUT;
- if (ret == NULL) {
- reply_with_perror ("%s", path);
- return NULL;
- }
-
- return ret; /* caller frees */
-}
diff --git a/daemon/realpath.ml b/daemon/realpath.ml
index e499786a1..8f83a7ad9 100644
--- a/daemon/realpath.ml
+++ b/daemon/realpath.ml
@@ -20,6 +20,10 @@ open Printf
open Std_utils
+let realpath path + let chroot = Chroot.create ~name:(sprintf "realpath:
%s" path) () in
+ Chroot.f chroot Unix_utils.Realpath.realpath path
+
(* The infamous case_sensitive_path function, which works around
* the bug in ntfs-3g that all paths are case sensitive even though
* the underlying filesystem is case insensitive.
diff --git a/daemon/realpath.mli b/daemon/realpath.mli
index 371e619fc..3da53c461 100644
--- a/daemon/realpath.mli
+++ b/daemon/realpath.mli
@@ -16,4 +16,5 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
+val realpath : string -> string
val case_sensitive_path : string -> string
diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index d720f43ff..e47469a6a 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -147,7 +147,6 @@ daemon/parted.c
daemon/pingdaemon.c
daemon/proto.c
daemon/readdir.c
-daemon/realpath.c
daemon/rename.c
daemon/rsync.c
daemon/scrub.c
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 070a1c641..4ec83d22d 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -4197,6 +4197,7 @@ compress- or gzip-compressed.
{ defaults with
name = "realpath"; added = (1, 0, 66);
style = RString (RPlainString, "rpath"), [String (Pathname,
"path")], [];
+ impl = OCaml "Realpath.realpath";
tests = [
InitISOFS, Always, TestResultString (
[["realpath"; "/../directory"]],
"/directory"), []
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 22/23] daemon: Reimplement ‘part_get_parttype’, ‘part_get_gpt_type’, ‘part_get_gpt_guid’ APIs in OCaml.
---
daemon/parted.c | 176 +++++-----------------------------------------
daemon/parted.ml | 74 ++++++++++++++++++-
daemon/parted.mli | 5 ++
generator/actions_core.ml | 3 +
4 files changed, 96 insertions(+), 162 deletions(-)
diff --git a/daemon/parted.c b/daemon/parted.c
index 3ad1ba147..72e1b8420 100644
--- a/daemon/parted.c
+++ b/daemon/parted.c
@@ -344,45 +344,6 @@ print_partition_table (const char *device, bool
add_m_option)
return out;
}
-char *
-do_part_get_parttype (const char *device)
-{
- CLEANUP_FREE char *out = print_partition_table (device, true);
- if (!out)
- return NULL;
-
- CLEANUP_FREE_STRING_LIST char **lines = split_lines (out);
- if (!lines)
- return NULL;
-
- if (lines[0] == NULL || STRNEQ (lines[0], "BYT;")) {
- reply_with_error ("unknown signature, expected \"BYT;\" as
first line of the output: %s",
- lines[0] ? lines[0] : "(signature was null)");
- return NULL;
- }
-
- if (lines[1] == NULL) {
- reply_with_error ("parted didn't return a line describing the
device");
- return NULL;
- }
-
- /* lines[1] is something like:
- * "/dev/sda:1953525168s:scsi:512:512:msdos:ATA Hitachi HDT72101;"
- */
- char *r = get_table_field (lines[1], 5);
- if (r == NULL)
- return NULL;
-
- /* If "loop" return an error (RHBZ#634246). */
- if (STREQ (r, "loop")) {
- free (r);
- reply_with_error ("not a partitioned device");
- return NULL;
- }
-
- return r;
-}
-
int
do_part_get_bootable (const char *device, int partnum)
{
@@ -553,126 +514,6 @@ do_part_set_gpt_guid (const char *device, int partnum,
const char *guid)
return 0;
}
-static char *
-sgdisk_info_extract_field (const char *device, int partnum, const char *field,
- char *(*extract) (const char *path))
-{
- if (partnum <= 0) {
- reply_with_error ("partition number must be >= 1");
- return NULL;
- }
-
- CLEANUP_FREE char *partnum_str = NULL;
- if (asprintf (&partnum_str, "%i", partnum) == -1) {
- reply_with_perror ("asprintf");
- return NULL;
- }
-
- udev_settle ();
-
- CLEANUP_FREE char *err = NULL;
- int r = commandf (NULL, &err, COMMAND_FLAG_FOLD_STDOUT_ON_STDERR,
- "sgdisk", device, "-i", partnum_str,
NULL);
-
- if (r == -1) {
- reply_with_error ("%s %s -i %s: %s", "sgdisk", device,
partnum_str, err);
- return NULL;
- }
-
- udev_settle ();
-
- CLEANUP_FREE_STRING_LIST char **lines = split_lines (err);
- if (lines == NULL) {
- reply_with_error ("'%s %s -i %i' returned no output",
- "sgdisk", device, partnum);
- return NULL;
- }
-
- const int fieldlen = strlen (field);
-
- /* Parse the output of sgdisk -i:
- * Partition GUID code: 21686148-6449-6E6F-744E-656564454649 (BIOS boot
partition)
- * Partition unique GUID: 19AEC5FE-D63A-4A15-9D37-6FCBFB873DC0
- * First sector: 2048 (at 1024.0 KiB)
- * Last sector: 411647 (at 201.0 MiB)
- * Partition size: 409600 sectors (200.0 MiB)
- * Attribute flags: 0000000000000000
- * Partition name: 'EFI System Partition'
- */
- for (char **i = lines; *i != NULL; i++) {
- char *line = *i;
-
- /* Skip blank lines */
- if (line[0] == '\0') continue;
-
- /* Split the line in 2 at the colon */
- char *colon = strchr (line, ':');
- if (colon) {
- if (colon - line == fieldlen &&
- memcmp (line, field, fieldlen) == 0)
- {
- /* The value starts after the colon */
- char *value = colon + 1;
-
- /* Skip any leading whitespace */
- value += strspn (value, " \t");
-
- /* Extract the actual information from the field. */
- char *ret = extract (value);
- if (ret == NULL) {
- /* The extraction function already sends the error. */
- return NULL;
- }
-
- return ret;
- }
- } else {
- /* Ignore lines with no colon. Log to stderr so it will show up in
- * LIBGUESTFS_DEBUG. */
- if (verbose) {
- fprintf (stderr, "get-gpt-type: unexpected sgdisk output ignored:
%s\n",
- line);
- }
- }
- }
-
- /* If we got here it means we didn't find the field */
- reply_with_error ("sgdisk output did not contain '%s'. "
- "See LIBGUESTFS_DEBUG output for more details",
field);
- return NULL;
-}
-
-static char *
-extract_uuid (const char *value)
-{
- /* The value contains only valid GUID characters */
- const size_t value_len = strspn (value, "-0123456789ABCDEF");
-
- char *ret = malloc (value_len + 1);
- if (ret == NULL) {
- reply_with_perror ("malloc");
- return NULL;
- }
-
- memcpy (ret, value, value_len);
- ret[value_len] = '\0';
- return ret;
-}
-
-char *
-do_part_get_gpt_type (const char *device, int partnum)
-{
- return sgdisk_info_extract_field (device, partnum,
- "Partition GUID code",
extract_uuid);
-}
-
-char *
-do_part_get_gpt_guid (const char *device, int partnum)
-{
- return sgdisk_info_extract_field (device, partnum,
- "Partition unique GUID",
extract_uuid);
-}
-
char *
do_part_get_name (const char *device, int partnum)
{
@@ -836,6 +677,23 @@ do_part_get_mbr_part_type (const char *device, int partnum)
return NULL;
}
+static char *
+extract_uuid (const char *value)
+{
+ /* The value contains only valid GUID characters */
+ const size_t value_len = strspn (value, "-0123456789ABCDEF");
+
+ char *ret = malloc (value_len + 1);
+ if (ret == NULL) {
+ reply_with_perror ("malloc");
+ return NULL;
+ }
+
+ memcpy (ret, value, value_len);
+ ret[value_len] = '\0';
+ return ret;
+}
+
char *
do_part_get_disk_guid (const char *device)
{
diff --git a/daemon/parted.ml b/daemon/parted.ml
index da31ab5c6..2e8e744d0 100644
--- a/daemon/parted.ml
+++ b/daemon/parted.ml
@@ -86,18 +86,18 @@ let print_partition_table_machine_readable device let out
= String.trim out in
let lines = String.nsplit "\n" out in
- (* lines[0] is "BYT;", lines[1] is the device line which we ignore,
+ (* lines[0] is "BYT;", lines[1] is the device line,
* lines[2..] are the partitions themselves.
*)
match lines with
- | "BYT;" :: _ :: lines -> lines
+ | "BYT;" :: device_line :: lines -> device_line, lines
| [] | [_] ->
failwith "too few rows of output from 'parted print'
command"
| _ ->
failwith "did not see 'BYT;' magic value in 'parted
print' command"
let part_list device - let lines = print_partition_table_machine_readable
device in
+ let _, lines = print_partition_table_machine_readable device in
List.map (
fun line ->
@@ -109,3 +109,71 @@ let part_list device failwithf "could not
parse row from output of 'parted print' command: %s: %s"
line err
) lines
+
+let part_get_parttype device + let device_line, _ =
print_partition_table_machine_readable device in
+
+ (* device_line is something like:
+ * "/dev/sda:1953525168s:scsi:512:512:msdos:ATA Hitachi HDT72101;"
+ *)
+ let fields = String.nsplit ":" device_line in
+ match fields with
+ | _::_::_::_::_::"loop"::_ -> (* If "loop" return an
error (RHBZ#634246). *)
+ failwithf "%s: not a partitioned device" device
+ | _::_::_::_::_::ret::_ -> ret
+ | _ ->
+ failwithf "%s: cannot parse the output of parted" device
+
+let rec part_get_gpt_type device partnum + sgdisk_info_extract_uuid_field
device partnum "Partition GUID code"
+and part_get_gpt_guid device partnum + sgdisk_info_extract_uuid_field device
partnum "Partition unique GUID"
+
+and sgdisk_info_extract_uuid_field device partnum field + if partnum <= 0
then failwith "partition number must be >= 1";
+
+ udev_settle ();
+
+ let r, _, err + commandr ~fold_stdout_on_stderr:true
+ "sgdisk" [ device; "-i"; string_of_int partnum
] in
+ if r <> 0 then
+ failwithf "sgdisk: %s" err;
+
+ udev_settle ();
+
+ let err = String.trim err in
+ let lines = String.nsplit "\n" err in
+
+ (* Parse the output of sgdisk -i:
+ * Partition GUID code: 21686148-6449-6E6F-744E-656564454649 (BIOS boot
partition)
+ * Partition unique GUID: 19AEC5FE-D63A-4A15-9D37-6FCBFB873DC0
+ * First sector: 2048 (at 1024.0 KiB)
+ * Last sector: 411647 (at 201.0 MiB)
+ * Partition size: 409600 sectors (200.0 MiB)
+ * Attribute flags: 0000000000000000
+ * Partition name: 'EFI System Partition'
+ *)
+ let field_len = String.length field in
+ let rec loop = function
+ | [] ->
+ failwithf "%s: sgdisk output did not contain '%s'"
device field
+ | line :: _ when String.is_prefix line field &&
+ String.length line >= field_len + 2 &&
+ line.[field_len] = ':' ->
+ let value + String.sub line (field_len+1) (String.length line -
field_len - 1) in
+
+ (* Skip any whitespace after the colon. *)
+ let value = String.triml value in
+
+ (* Extract the UUID. *)
+ extract_uuid value
+
+ | _ :: lines -> loop lines
+ in
+ loop lines
+
+and extract_uuid value + (* The value contains only valid GUID characters. *)
+ String.sub value 0 (String.span value "-0123456789ABCDEF")
diff --git a/daemon/parted.mli b/daemon/parted.mli
index 057d7e8c7..5a77a8779 100644
--- a/daemon/parted.mli
+++ b/daemon/parted.mli
@@ -25,3 +25,8 @@ type partition = {
val part_get_mbr_id : string -> int -> int
val part_list : string -> partition list
+
+val part_get_parttype : string -> string
+
+val part_get_gpt_type : string -> int -> string
+val part_get_gpt_guid : string -> int -> string
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 4ec83d22d..c3421133e 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -5073,6 +5073,7 @@ Size of the partition in bytes.
{ defaults with
name = "part_get_parttype"; added = (1, 0, 78);
style = RString (RPlainString, "parttype"), [String (Device,
"device")], [];
+ impl = OCaml "Parted.part_get_parttype";
tests = [
InitEmpty, Always, TestResultString (
[["part_disk"; "/dev/sda"; "gpt"];
@@ -8247,6 +8248,7 @@ for a useful list of type GUIDs." };
{ defaults with
name = "part_get_gpt_type"; added = (1, 21, 1);
style = RString (RPlainString, "guid"), [String (Device,
"device"); Int "partnum"], [];
+ impl = OCaml "Parted.part_get_gpt_type";
optional = Some "gdisk";
tests = [
InitGPT, Always, TestResultString (
@@ -9067,6 +9069,7 @@ valid GUID." };
{ defaults with
name = "part_get_gpt_guid"; added = (1, 29, 25);
style = RString (RPlainString, "guid"), [String (Device,
"device"); Int "partnum"], [];
+ impl = OCaml "Parted.part_get_gpt_guid";
optional = Some "gdisk";
tests = [
InitGPT, Always, TestResultString (
--
2.13.2
Richard W.M. Jones
2017-Jul-27 19:43 UTC
[Libguestfs] [PATCH v3 23/23] daemon: Reimplement ‘device_index’ API in OCaml.
---
daemon/devsparts.c | 21 ---------------------
daemon/devsparts.ml | 11 +++++++++++
daemon/devsparts.mli | 6 ++----
generator/actions_core.ml | 1 +
4 files changed, 14 insertions(+), 25 deletions(-)
diff --git a/daemon/devsparts.c b/daemon/devsparts.c
index 12e779326..7c65be1dc 100644
--- a/daemon/devsparts.c
+++ b/daemon/devsparts.c
@@ -33,27 +33,6 @@
#include "daemon.h"
#include "actions.h"
-int
-do_device_index (const char *device)
-{
- size_t i;
- int ret = -1;
- CLEANUP_FREE_STRING_LIST char **devices = do_list_devices ();
-
- if (devices == NULL)
- return -1;
-
- for (i = 0; devices[i] != NULL; ++i) {
- if (STREQ (device, devices[i]))
- ret = (int) i;
- }
-
- if (ret == -1)
- reply_with_error ("device not found");
-
- return ret;
-}
-
#define GUESTFSDIR "/dev/disk/guestfs"
char **
diff --git a/daemon/devsparts.ml b/daemon/devsparts.ml
index 86963899f..9f9751b40 100644
--- a/daemon/devsparts.ml
+++ b/daemon/devsparts.ml
@@ -113,3 +113,14 @@ let is_whole_device device
try ignore (stat devpath); true
with Unix_error ((ENOENT|ENOTDIR), _, _) -> false
+
+let device_index device + (* This is the algorithm which was used by the C
version. Why
+ * can't we use drive_index from C_utils? XXX
+ *)
+ let rec loop i = function
+ | [] -> failwithf "%s: device not found" device
+ | dev :: devices when dev = device -> i
+ | _ :: devices -> loop (i+1) devices
+ in
+ loop 0 (list_devices ())
diff --git a/daemon/devsparts.mli b/daemon/devsparts.mli
index 8be47e752..4afb36bec 100644
--- a/daemon/devsparts.mli
+++ b/daemon/devsparts.mli
@@ -18,10 +18,8 @@
val list_devices : unit -> string list
val list_partitions : unit -> string list
-
-val nr_devices : unit -> int
-
val part_to_dev : string -> string
val part_to_partnum : string -> int
-
val is_whole_device : string -> bool
+val nr_devices : unit -> int
+val device_index : string -> int
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index c3421133e..ea0735676 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -7419,6 +7419,7 @@ instead of, or after calling
C<guestfs_zero_free_space>." };
{ defaults with
name = "device_index"; added = (1, 19, 7);
style = RInt "index", [String (Device, "device")], [];
+ impl = OCaml "Devsparts.device_index";
tests = [
InitEmpty, Always, TestResult (
[["device_index"; "/dev/sda"]], "ret ==
0"), []
--
2.13.2
Maybe Matching Threads
- [PATCH v2 00/23] Reimplement many daemon APIs in OCaml.
- [PATCH v3 00/19] Allow APIs to be implemented in OCaml.
- [PATCH 00/27] Reimplement many daemon APIs in OCaml.
- [PATCH v2 00/12] Allow APIs to be implemented in OCaml.
- [PATCH v7 00/29] Reimplement inspection in the daemon.