Richard W.M. Jones
2017-Jul-21 20:36 UTC
[Libguestfs] [PATCH v2 00/23] Reimplement many daemon APIs in OCaml.
v1 was posted here:
https://www.redhat.com/archives/libguestfs/2017-July/msg00098.html
This series now depends on two small patches which I posted separately:
https://www.redhat.com/archives/libguestfs/2017-July/msg00207.html
https://www.redhat.com/archives/libguestfs/2017-July/msg00209.html
v1 -> v2:
- Previously changes to generator/daemon.ml were made incrementally
through the patch series. Now these changes are moved into the
first patch. This wasn't quite straightforward because I also had
to move the static functions into a separate file so that bisection
wouldn't break.
- Related to previous change, move ocaml_exn_to_reply_with_error to
daemon/daemon-c.c, and rename it
guestfs_int_daemon_exn_to_reply_with_error.
- Move separate patches implementing optgroups and
CommandFlagFoldStdoutOnStderr into the first patch.
- daemon/Makefile.am: Deduplicate BUILT_SOURCES & generator_built vars.
- daemon/chroot.mli: In a comment, fix misspelled parmeter -> parameter.
- daemon/utils.ml: Use stringify_args.
- Add a chomp function to Std_utils [patch posted separately]
and use it in daemon/utils.ml.
- Add Sysroot.sysroot_path function which works like the C function
and use it throughout.
- Modify Chroot.create with optional ?chroot parameter, so you don't
need to call Sysroot followed by Chroot in two steps.
- get_blkid_tag: Add device name to error message as in C equiv.
- get_blkid_tag: Use String.chomp instead of String.trimr, since
that's closer to what the C code does.
- Replace O_CLOEXEC with Unix.set_close_on_exec. We'll need to fix
this properly at some point, especially if we make the daemon
multithreaded.
- Simplify (fun dev -> "/dev/" ^ dev) -> ((^) "/dev/")
as suggested.
- Factored the functions in daemon/is.ml about as far as is possible.
- daemon/parted.ml: Use triml before sscanf.
- daemon/filearch.ml: Remove comment about "caller must free".
- daemon/filearch.ml: Use Unix_utils.Mkdtemp instead of making by hand,
and clean up afterwards.
- daemon/ldm.ml: Factor the two functions as far as possible.
- daemon/lvm.ml: Readd the comment above lvs_has_S_opt which was
accidentally dropped during conversion.
- daemon/lvm.ml: Optimize handling of prefix in convert_lvm_output.
- daemon/optgroups.c: Remove unnecessary <stdio.h>, <stdlib.h>
additions.
- daemon/optgroups.c: Use optgroup_names so we don't need to check
for non-retired groups.
- daemon/btrfs.ml: Rewrite ‘with_mounted’ helper to use Mkdtemp.
- daemon/btrfs.ml: Filter empty lines.
- daemon/listfs.ml: Use StringSet to simplify filtering the
devices.
- daemon/parted.ml: Fix print_partition_table and add a comment
so it's clear this version only works in -m mode.
- daemon/md.ml: Filter empty lines.
- Reran the tests.
Requested, but not done for various reasons:
- Combining Utils, Sysroot, Chroot modules into Daemon. Not possible
because of the order of initialization of the modules (Daemon must
come after everything else, whereas the others must come before
everything else). It would be possible to combine Sysroot and
Chroot together completely , but since they are separate modules
with different purposes there didn't seem much point. However I
did modify the Chroot.create ?chroot function -- see above.
- Writing C bindings to command* functions: too complex, and the OCaml
replacements are better anyway.
- Reimplement udev_settle{,_file} as wrappers around C functions.
I tried to make this change but it is unexpectedly complex, because
it would mean that daemon/utils.ml contains a C function which can
only be satisfied by linking to the daemon, but daemon_utils_tests
is a standalone program which cannot be linked to the daemon. So
we'd either need to create another OCaml module, or split up the C
parts of the daemon into "library bits" and "daemon bits".
- Removing GUESTFSD_EXT_CMD. This is still being used by OpenSUSE, so
we'll have to think of a better mechanism for it. Something like
‘guestfsd --dump-commands’ may work better.
- Replace compare with subtraction in daemon/devsparts.ml. I find the
compare version easier to understand.
- In parted.ml, didn't replace sscanf " %x", since my reading is
that
OCaml sscanf works the same way as C sscanf with regard to spaces,
ie. it will eat any amount of leading whitespace.
- Generating:
external available : unit -> bool =
"guestfs_int_daemon_optgroup..."
etc. It's hard to generate these functions and have them added to the
correct modules (since the OCaml modules are hand-written, and it's
awkward to include generated bits in them).
Other notes:
- daemon must be linked to -ldl -lm because the OCaml runtime
(libasmrun.so) depends on both.
- Structs must be repeated in *.mli files because you can't use OCaml
‘include’ to pick up single structs from another module. However
the structs are still type checked by the compiler, so we cannot
write incorrect / untyped code this way.
Rich.
Richard W.M. Jones
2017-Jul-21 20:36 UTC
[Libguestfs] [PATCH v2 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 | 7 +-
Makefile.am | 2 +-
common/mlutils/Makefile.am | 4 -
daemon/Makefile.am | 121 +++++++++++++---
daemon/chroot.ml | 85 ++++++++++++
daemon/chroot.mli | 38 +++++
daemon/daemon-c.c | 203 +++++++++++++++++++++++++++
daemon/daemon-c.h | 38 +++++
daemon/daemon.ml | 39 ++++++
daemon/guestfsd.c | 5 +
daemon/sysroot-c.c | 37 +++++
daemon/sysroot.ml | 23 ++++
daemon/sysroot.mli | 25 ++++
daemon/utils.ml | 160 +++++++++++++++++++++
daemon/utils.mli | 72 ++++++++++
docs/C_SOURCE_FILES | 4 +
docs/guestfs-hacking.pod | 7 +
generator/OCaml.ml | 8 ++
generator/OCaml.mli | 1 +
generator/actions.ml | 5 +
generator/actions.mli | 4 +
generator/daemon.ml | 337 ++++++++++++++++++++++++++++++++++++++++++++-
generator/daemon.mli | 3 +
generator/main.ml | 8 ++
generator/types.ml | 7 +-
25 files changed, 1215 insertions(+), 28 deletions(-)
diff --git a/.gitignore b/.gitignore
index bbd9284c6..4f10327c4 100644
--- a/.gitignore
+++ b/.gitignore
@@ -165,20 +165,25 @@ Makefile.in
/customize/test-settings-*.sh
/customize/virt-customize
/customize/virt-customize.1
+/daemon/.depend
/daemon/actions.h
+/daemon/callbacks.ml
+/daemon/caml-stubs.c
/daemon/dispatch.c
/daemon/guestfsd
/daemon/guestfsd.8
/daemon/guestfsd.exe
+/daemon/lvm-tokenization.c
/daemon/names.c
/daemon/optgroups.c
/daemon/optgroups.h
-/daemon/lvm-tokenization.c
/daemon/stamp-guestfsd.pod
/daemon/structs-cleanups.c
/daemon/structs-cleanups.h
+/daemon/structs.ml
/daemon/stubs-?.c
/daemon/stubs.h
+/daemon/types.ml
/depcomp
/df/stamp-virt-df.pod
/df/virt-df
diff --git a/Makefile.am b/Makefile.am
index a411b0b7b..84b00393d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -44,6 +44,7 @@ SUBDIRS += common/structs
SUBDIRS += lib docs examples po
# The daemon and the appliance.
+SUBDIRS += common/mlutils
if ENABLE_DAEMON
SUBDIRS += daemon
SUBDIRS += tests/daemon
@@ -155,7 +156,6 @@ SUBDIRS += csharp
# OCaml tools. Note 'common/ml*', 'mllib' and
'customize' contain
# shared code used by other OCaml tools, so these must come first.
if HAVE_OCAML
-SUBDIRS += common/mlutils
SUBDIRS += common/mlprogress
SUBDIRS += common/mlvisit
SUBDIRS += common/mlxml
diff --git a/common/mlutils/Makefile.am b/common/mlutils/Makefile.am
index 94b2187eb..f29ffc062 100644
--- a/common/mlutils/Makefile.am
+++ b/common/mlutils/Makefile.am
@@ -35,8 +35,6 @@ SOURCES_C = \
c_utils-c.c \
unix_utils-c.c
-if HAVE_OCAML
-
# We pretend that we're building a C library. automake handles the
# compilation of the C sources for us. At the end we take the C
# objects and OCaml objects and link them into the OCaml library.
@@ -150,6 +148,4 @@ depend: .depend
-include .depend
-endif
-
.PHONY: depend docs
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index eedf09d52..67a26de06 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -17,27 +17,31 @@
include $(top_srcdir)/subdir-rules.mk
-generator_built = \
- actions.h \
- dispatch.c \
- names.c \
- lvm-tokenization.c \
- structs-cleanups.c \
- structs-cleanups.h \
- stubs-0.c \
- stubs-1.c \
- stubs-2.c \
- stubs-3.c \
- stubs-4.c \
- stubs-5.c \
- stubs-6.c \
- stubs.h
-
BUILT_SOURCES = \
- $(generator_built)
+ actions.h \
+ caml-stubs.c \
+ dispatch.c \
+ names.c \
+ lvm-tokenization.c \
+ structs-cleanups.c \
+ structs-cleanups.h \
+ stubs-0.c \
+ stubs-1.c \
+ stubs-2.c \
+ stubs-3.c \
+ stubs-4.c \
+ stubs-5.c \
+ stubs-6.c \
+ stubs.h
-EXTRA_DIST = \
+generator_built = \
$(BUILT_SOURCES) \
+ callbacks.ml \
+ types.ml
+
+EXTRA_DIST = \
+ $(generator_built) \
+ $(SOURCES_MLI) $(SOURCES_ML) \
guestfsd.pod
if INSTALL_DAEMON
@@ -61,6 +65,7 @@ guestfsd_SOURCES = \
blkid.c \
blockdev.c \
btrfs.c \
+ caml-stubs.c \
cap.c \
checksum.c \
cleanups.c \
@@ -71,6 +76,8 @@ guestfsd_SOURCES = \
copy.c \
cpio.c \
cpmv.c \
+ daemon-c.c \
+ daemon-c.h \
daemon.h \
dd.c \
debug.c \
@@ -161,6 +168,7 @@ guestfsd_SOURCES = \
swap.c \
sync.c \
syslinux.c \
+ sysroot-c.c \
tar.c \
tsk.c \
truncate.c \
@@ -176,10 +184,16 @@ guestfsd_SOURCES = \
zero.c \
zerofree.c
+guestfsd_LDFLAGS = \
+ -L$(shell $(OCAMLC) -where) \
+ -L$(shell $(OCAMLC) -where)/hivex \
+ -L../common/mlutils \
+ -L../common/mlstdutils
guestfsd_LDADD = \
../common/errnostring/liberrnostring.la \
../common/protocol/libprotocol.la \
../common/utils/libutils.la \
+ camldaemon.o \
$(ACL_LIBS) \
$(CAP_LIBS) \
$(YAJL_LIBS) \
@@ -198,9 +212,12 @@ guestfsd_LDADD = \
$(PCRE_LIBS) \
$(TSK_LIBS) \
$(RPC_LIBS) \
- $(YARA_LIBS)
+ $(YARA_LIBS) \
+ $(OCAML_LIBS)
guestfsd_CPPFLAGS = \
+ -I$(shell $(OCAMLC) -where) \
+ -I$(shell $(OCAMLC) -where)/hivex \
-I$(top_srcdir)/gnulib/lib \
-I$(top_builddir)/gnulib/lib \
-I$(top_srcdir)/lib \
@@ -220,6 +237,70 @@ guestfsd_CFLAGS = \
$(YAJL_CFLAGS) \
$(PCRE_CFLAGS)
+# Parts of the daemon are written in OCaml. These are linked into a
+# library and then linked to the daemon. See
+# https://caml.inria.fr/pub/docs/manual-ocaml/intfc.html
+SOURCES_MLI = \
+ chroot.mli \
+ sysroot.mli \
+ utils.mli
+
+SOURCES_ML = \
+ types.ml \
+ utils.ml \
+ structs.ml \
+ sysroot.ml \
+ chroot.ml \
+ callbacks.ml \
+ daemon.ml
+
+BOBJECTS = $(SOURCES_ML:.ml=.cmo)
+XOBJECTS = $(BOBJECTS:.cmo=.cmx)
+
+OCAMLPACKAGES = \
+ -package str,unix,hivex \
+ -I $(top_srcdir)/common/mlstdutils \
+ -I $(top_srcdir)/common/mlutils
+
+OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_FLAGS)
+
+if !HAVE_OCAMLOPT
+OBJECTS = $(BOBJECTS)
+CAMLRUN = camlrun
+else
+OBJECTS = $(XOBJECTS)
+CAMLRUN = asmrun
+endif
+OCAML_LIBS = \
+ -lmlcutils \
+ -lmlstdutils \
+ -lmlhivex \
+ -lcamlstr \
+ -lunix \
+ -l$(CAMLRUN) -ldl -lm
+
+CLEANFILES += camldaemon.o
+
+camldaemon.o: $(OBJECTS)
+ $(OCAMLFIND) $(BEST) -output-obj -o $@ \
+ $(OCAMLFLAGS) $(OCAMLPACKAGES) \
+ -linkpkg mlcutils.$(MLARCHIVE) mlstdutils.$(MLARCHIVE) \
+ $(OBJECTS)
+
+# OCaml dependencies.
+depend: .depend
+
+.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml)
+ rm -f $@ $@-t
+ $(OCAMLFIND) ocamldep -I $(abs_srcdir) -I
$(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlutils $^ |
\
+ $(SED) 's/ *$$//' | \
+ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \
+ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \
+ sort > $@-t
+ mv $@-t $@
+
+-include .depend
+
# Manual pages and HTML files for the website.
if INSTALL_DAEMON
man_MANS = guestfsd.8
@@ -241,4 +322,4 @@ stamp-guestfsd.pod: guestfsd.pod
$<
touch $@
-.PHONY: force
+.PHONY: depend force
diff --git a/daemon/chroot.ml b/daemon/chroot.ml
new file mode 100644
index 000000000..3364cd20b
--- /dev/null
+++ b/daemon/chroot.ml
@@ -0,0 +1,85 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Printf
+open Unix
+
+open Std_utils
+open Unix_utils
+
+type t = {
+ name : string;
+ chroot : string;
+}
+
+let create ?(name = "<unnamed>") ?(chroot = Sysroot.sysroot ())
() + { name = name; chroot = chroot }
+
+let f t func arg + if verbose () then
+ eprintf "chroot: %s: running '%s'\n%!" t.chroot t.name;
+
+ let rfd, wfd = pipe () in
+
+ let pid = fork () in
+ if pid = 0 then (
+ (* Child. *)
+ close rfd;
+
+ chdir t.chroot;
+ chroot t.chroot;
+
+ let ret + try Either (func arg)
+ with exn -> Or exn in
+
+ try
+ let chan = out_channel_of_descr wfd in
+ output_value chan ret;
+ Pervasives.flush chan;
+ Exit._exit 0
+ with
+ exn ->
+ prerr_endline (Printexc.to_string exn);
+ Exit._exit 1
+ );
+
+ (* Parent. *)
+ close wfd;
+
+ let _, status = waitpid [] pid in
+ (match status with
+ | WEXITED 0 -> ()
+ | WEXITED i ->
+ close rfd;
+ failwithf "chroot ‘%s’ exited with non-zero error %d" t.name i
+ | WSIGNALED i ->
+ close rfd;
+ failwithf "chroot ‘%s’ killed by signal %d" t.name i
+ | WSTOPPED i ->
+ close rfd;
+ failwithf "chroot ‘%s’ stopped by signal %d" t.name i
+ );
+
+ let chan = in_channel_of_descr rfd in
+ let ret = input_value chan in
+ close_in chan;
+
+ match ret with
+ | Either ret -> ret
+ | Or exn -> raise exn
diff --git a/daemon/chroot.mli b/daemon/chroot.mli
new file mode 100644
index 000000000..33f53ba18
--- /dev/null
+++ b/daemon/chroot.mli
@@ -0,0 +1,38 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(** This is a generic module for running functions in a chroot.
+ The function runs in a forked subprocess too so that we can
+ restore the root afterwards.
+
+ It handles passing the parameter, forking, running the
+ function and marshalling the result or any exceptions. *)
+
+type t
+
+val create : ?name:string -> ?chroot:string -> unit -> t
+(** Create a chroot handle.
+
+ [?name] is an optional name used in debugging and error messages.
+
+ [?chroot] is the optional chroot directory. This parameter
+ defaults to [Sysroot.sysroot ()]. *)
+
+val f : t -> ('a -> 'b) -> 'a -> 'b
+(** Run a function in the chroot, returning the result or re-raising
+ any exception thrown. *)
diff --git a/daemon/daemon-c.c b/daemon/daemon-c.c
new file mode 100644
index 000000000..cbb3d8918
--- /dev/null
+++ b/daemon/daemon-c.c
@@ -0,0 +1,203 @@
+/* guestfs-inspection
+ * Copyright (C) 2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA.
+ */
+
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <caml/alloc.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/unixsupport.h>
+
+#include "daemon.h"
+#include "daemon-c.h"
+
+/* Convert an OCaml exception to a reply_with_error_errno call
+ * as best we can.
+ */
+void
+guestfs_int_daemon_exn_to_reply_with_error (const char *func, value exn)
+{
+ const char *exn_name;
+
+ /* This is not the official way to do this, but I could not get the
+ * official way to work, and this way does work. See
+ *
http://caml.inria.fr/pub/ml-archives/caml-list/2006/05/097f63cfb39a80418f95c70c3c520aa8.en.html
+ *
http://caml.inria.fr/pub/ml-archives/caml-list/2009/06/797e2f797f57b8ea2a2c0e431a2df312.en.html
+ */
+ if (Tag_val (Field (exn, 0)) == String_tag)
+ /* For End_of_file and a few other constant exceptions. */
+ exn_name = String_val (Field (exn, 0));
+ else
+ /* For most exceptions. */
+ exn_name = String_val (Field (Field (exn, 0), 0));
+
+ if (verbose)
+ fprintf (stderr, "ocaml_exn: '%s' raised '%s'
exception\n",
+ func, exn_name);
+
+ if (STREQ (exn_name, "Unix.Unix_error")) {
+ int errcode = code_of_unix_error (Field (exn, 1));
+ reply_with_perror_errno (errcode, "%s: %s",
+ String_val (Field (exn, 2)),
+ String_val (Field (exn, 3)));
+ }
+ else if (STREQ (exn_name, "Failure"))
+ reply_with_error ("%s", String_val (Field (exn, 1)));
+ else if (STREQ (exn_name, "Sys_error"))
+ reply_with_error ("%s", String_val (Field (exn, 1)));
+ else if (STREQ (exn_name, "Invalid_argument"))
+ reply_with_error ("invalid argument: %s", String_val (Field (exn,
1)));
+ else
+ reply_with_error ("internal error: %s: unhandled exception thrown:
%s",
+ func, exn_name);
+}
+
+/* NB: This is a "noalloc" call. */
+value
+guestfs_int_daemon_get_verbose_flag (value unitv)
+{
+ return Val_bool (verbose);
+}
+
+/* Implement String (Mountable, _) parameter. */
+value
+guestfs_int_daemon_copy_mountable (const mountable_t *mountable)
+{
+ CAMLparam0 ();
+ CAMLlocal4 (r, typev, devicev, volumev);
+
+ switch (mountable->type) {
+ case MOUNTABLE_DEVICE:
+ typev = Val_int (0); /* MountableDevice */
+ break;
+ case MOUNTABLE_PATH:
+ typev = Val_int (1); /* MountablePath */
+ break;
+ case MOUNTABLE_BTRFSVOL:
+ volumev = caml_copy_string (mountable->volume);
+ typev = caml_alloc (1, 0); /* MountableBtrfsVol */
+ Store_field (typev, 0, volumev);
+ }
+
+ devicev = caml_copy_string (mountable->device);
+
+ r = caml_alloc_tuple (2);
+ Store_field (r, 0, typev);
+ Store_field (r, 1, devicev);
+
+ CAMLreturn (r);
+}
+
+/* Implement RStringList. */
+char **
+guestfs_int_daemon_return_string_list (value retv)
+{
+ CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
+ value v;
+
+ while (retv != Val_int (0)) {
+ v = Field (retv, 0);
+ if (add_string (&ret, String_val (v)) == -1)
+ return NULL;
+ retv = Field (retv, 1);
+ }
+
+ if (end_stringsbuf (&ret) == -1)
+ return NULL;
+
+ return take_stringsbuf (&ret); /* caller frees */
+}
+
+/* Implement RString (RMountable, _). */
+char *
+guestfs_int_daemon_return_string_mountable (value retv)
+{
+ value typev = Field (retv, 0);
+ value devicev = Field (retv, 1);
+ value subvolv;
+ char *ret;
+
+ if (Is_long (typev)) { /* MountableDevice or MountablePath */
+ ret = strdup (String_val (devicev));
+ if (ret == NULL)
+ reply_with_perror ("strdup");
+ return ret;
+ }
+ else { /* MountableBtrfsVol of subvol */
+ subvolv = Field (typev, 0);
+ if (asprintf (&ret, "btrfsvol:%s/%s",
+ String_val (devicev), String_val (subvolv)) == -1)
+ reply_with_perror ("asprintf");
+ return ret;
+ }
+}
+
+/* Implement RHashtable (RPlainString, RPlainString, _). */
+char **
+guestfs_int_daemon_return_hashtable_string_string (value retv)
+{
+ CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
+ value v, sv;
+
+ while (retv != Val_int (0)) {
+ v = Field (retv, 0); /* (string, string) */
+ sv = Field (v, 0); /* string */
+ if (add_string (&ret, String_val (sv)) == -1)
+ return NULL;
+ sv = Field (v, 1); /* string */
+ if (add_string (&ret, String_val (sv)) == -1)
+ return NULL;
+ retv = Field (retv, 1);
+ }
+
+ if (end_stringsbuf (&ret) == -1)
+ return NULL;
+
+ return take_stringsbuf (&ret); /* caller frees */
+}
+
+/* Implement RHashtable (RMountable, RPlainString, _). */
+char **
+guestfs_int_daemon_return_hashtable_mountable_string (value retv)
+{
+ CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
+ value v, mv, sv;
+ char *m;
+
+ while (retv != Val_int (0)) {
+ v = Field (retv, 0); /* (Mountable.t, string) */
+ mv = Field (v, 0); /* Mountable.t */
+ m = guestfs_int_daemon_return_string_mountable (mv);
+ if (m == NULL)
+ return NULL;
+ if (add_string_nodup (&ret, m) == -1)
+ return NULL;
+ sv = Field (v, 1); /* string */
+ if (add_string (&ret, String_val (sv)) == -1)
+ return NULL;
+ retv = Field (retv, 1);
+ }
+
+ if (end_stringsbuf (&ret) == -1)
+ return NULL;
+
+ return take_stringsbuf (&ret); /* caller frees */
+}
diff --git a/daemon/daemon-c.h b/daemon/daemon-c.h
new file mode 100644
index 000000000..1b9f102ff
--- /dev/null
+++ b/daemon/daemon-c.h
@@ -0,0 +1,38 @@
+/* guestfs-inspection
+ * Copyright (C) 2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA.
+ */
+
+/* This file is separate from <daemon.h> because we don't want to
+ * include the OCaml headers (to get 'value') for the whole daemon.
+ */
+
+#ifndef GUESTFSD_DAEMON_C_H
+#define GUESTFSD_DAEMON_C_H
+
+#include "daemon.h"
+
+#include <caml/mlvalues.h>
+
+extern value guestfs_int_daemon_get_verbose_flag (value unitv);
+extern void guestfs_int_daemon_exn_to_reply_with_error (const char *func, value
exn);
+extern value guestfs_int_daemon_copy_mountable (const mountable_t *mountable);
+extern char **guestfs_int_daemon_return_string_list (value retv);
+extern char *guestfs_int_daemon_return_string_mountable (value retv);
+extern char **guestfs_int_daemon_return_hashtable_string_string (value retv);
+extern char **guestfs_int_daemon_return_hashtable_mountable_string (value
retv);
+
+#endif /* GUESTFSD_DAEMON_C_H */
diff --git a/daemon/daemon.ml b/daemon/daemon.ml
new file mode 100644
index 000000000..45bac029a
--- /dev/null
+++ b/daemon/daemon.ml
@@ -0,0 +1,39 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Printf
+
+external get_verbose_flag : unit -> bool +
"guestfs_int_daemon_get_verbose_flag" "noalloc"
+
+(* When guestfsd starts up, after initialization but before accepting
+ * messages, it calls 'caml_startup' which runs all initialization code
+ * in the OCaml modules, including this one. Therefore this is where
+ * we can place OCaml initialization code for the daemon.
+ *)
+let () + (* Connect the guestfsd [-v] (verbose) flag into 'verbose ()'
+ * used in OCaml code to print debugging messages.
+ *)
+ if get_verbose_flag () then (
+ Std_utils.set_verbose ();
+ eprintf "OCaml daemon loaded\n%!"
+ );
+
+ (* Register the callbacks which are used to call OCaml code from C. *)
+ Callbacks.init_callbacks ()
diff --git a/daemon/guestfsd.c b/daemon/guestfsd.c
index b3f40628b..ddc49ed44 100644
--- a/daemon/guestfsd.c
+++ b/daemon/guestfsd.c
@@ -56,6 +56,8 @@
#include <augeas.h>
+#include <caml/callback.h> /* for caml_startup */
+
#include "sockets.h"
#include "c-ctype.h"
#include "ignore-value.h"
@@ -348,6 +350,9 @@ main (int argc, char *argv[])
*/
udev_settle ();
+ /* Initialize the OCaml stubs. */
+ caml_startup (argv);
+
/* Send the magic length message which indicates that
* userspace is up inside the guest.
*/
diff --git a/daemon/sysroot-c.c b/daemon/sysroot-c.c
new file mode 100644
index 000000000..ad31d36ee
--- /dev/null
+++ b/daemon/sysroot-c.c
@@ -0,0 +1,37 @@
+/* guestfs-inspection
+ * Copyright (C) 2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA.
+ */
+
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+#include "daemon.h"
+
+extern value guestfs_int_daemon_sysroot (value unitv);
+
+value
+guestfs_int_daemon_sysroot (value unitv)
+{
+ return caml_copy_string (sysroot);
+}
diff --git a/daemon/sysroot.ml b/daemon/sysroot.ml
new file mode 100644
index 000000000..262890952
--- /dev/null
+++ b/daemon/sysroot.ml
@@ -0,0 +1,23 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Std_utils
+
+external sysroot : unit -> string = "guestfs_int_daemon_sysroot"
+
+let sysroot_path path = sysroot () // path
diff --git a/daemon/sysroot.mli b/daemon/sysroot.mli
new file mode 100644
index 000000000..f99ab0d54
--- /dev/null
+++ b/daemon/sysroot.mli
@@ -0,0 +1,25 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+val sysroot : unit -> string
+(** Return the current sysroot path where filesystems are mounted.
+ This comes from the daemon command line ([-r] option) or a built
+ in default. *)
+
+val sysroot_path : string -> string
+(** Equivalent to calling [sysroot () // path] *)
diff --git a/daemon/utils.ml b/daemon/utils.ml
new file mode 100644
index 000000000..347ed613b
--- /dev/null
+++ b/daemon/utils.ml
@@ -0,0 +1,160 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Unix
+open Printf
+
+open Std_utils
+
+let prog_exists prog + try ignore (which prog); true
+ with Executable_not_found _ -> false
+
+type command_flag + CommandFlagFoldStdoutOnStderr
+
+let commandr ?(flags = []) prog args + let fold_stdout_on_stderr = List.mem
CommandFlagFoldStdoutOnStderr flags in
+
+ if verbose () then
+ eprintf "command: %s %s\n%!"
+ (if fold_stdout_on_stderr then " fold-stdout-on-stderr"
else "")
+ (stringify_args (prog :: args));
+
+ let argv = Array.of_list (prog :: args) in
+
+ let stdout_file, stdout_chan = Filename.open_temp_file "cmd"
".out" in
+ let stderr_file, stderr_chan = Filename.open_temp_file "cmd"
".err" in
+ let stdout_fd = descr_of_out_channel stdout_chan in
+ let stderr_fd = descr_of_out_channel stderr_chan in
+ let stdin_fd = openfile "/dev/null" [O_RDONLY] 0 in
+
+ let pid = fork () in
+ if pid = 0 then (
+ (* Child process. *)
+ dup2 stdin_fd stdin;
+ close stdin_fd;
+ if not fold_stdout_on_stderr then
+ dup2 stdout_fd stdout
+ else
+ dup2 stderr_fd stdout;
+ close stdout_fd;
+ dup2 stderr_fd stderr;
+ close stderr_fd;
+
+ execvp prog argv
+ );
+
+ (* Parent process. *)
+ close stdin_fd;
+ close stdout_fd;
+ close stderr_fd;
+ let _, status = waitpid [] pid in
+ let r + match status with
+ | WEXITED i -> i
+ | WSIGNALED i ->
+ failwithf "external command ‘%s’ killed by signal %d" prog i
+ | WSTOPPED i ->
+ failwithf "external command ‘%s’ stopped by signal %d" prog i
in
+
+ if verbose () then
+ eprintf "command: %s returned %d\n" prog r;
+
+ let stdout = read_whole_file stdout_file in
+ let stderr = read_whole_file stderr_file in
+
+ if verbose () then (
+ if stdout <> "" then (
+ eprintf "command: %s: stdout:\n%s%!" prog stdout;
+ if not (String.is_suffix stdout "\n") then eprintf
"\n%!"
+ );
+ if stderr <> "" then (
+ eprintf "command: %s: stderr:\n%s%!" prog stderr;
+ if not (String.is_suffix stderr "\n") then eprintf
"\n%!"
+ )
+ );
+
+ (* Strip trailing \n from stderr but NOT from stdout. *)
+ let stderr = String.chomp stderr in
+
+ (r, stdout, stderr)
+
+let command ?flags prog args + let r, stdout, stderr = commandr ?flags prog
args in
+ if r <> 0 then
+ failwithf "%s exited with status %d: %s" prog r stderr;
+ stdout
+
+let udev_settle ?filename () + let args = ref [] in
+ if verbose () then
+ push_back args "--debug";
+ push_back args "settle";
+ (match filename with
+ | None -> ()
+ | Some filename ->
+ push_back args "-E";
+ push_back args filename
+ );
+ let args = !args in
+ let r, _, err = commandr "udevadm" args in
+ if r <> 0 then
+ eprintf "udevadm settle: %s\n" err
+
+let root_device = lazy ((stat "/").st_dev)
+
+let is_root_device_stat statbuf + statbuf.st_rdev = Lazy.force root_device
+
+let is_root_device device + udev_settle ~filename:device ();
+ try
+ let statbuf = stat device in
+ is_root_device_stat statbuf
+ with
+ Unix_error (err, func, arg) ->
+ eprintf "is_root_device: %s: %s: %s: %s\n"
+ device func arg (error_message err);
+ false
+
+let proc_unmangle_path path + let n = String.length path in
+ let b = Buffer.create n in
+ let rec loop i + if i < n-3 && path.[i] = '\\' then (
+ let to_int c = Char.code c - Char.code '0' in
+ let v + (to_int path.[i+1] lsl 6) lor
+ (to_int path.[i+2] lsl 3) lor
+ to_int path.[i+3] in
+ Buffer.add_char b (Char.chr v);
+ loop (i+4)
+ )
+ else if i < n then (
+ Buffer.add_char b path.[i];
+ loop (i+1)
+ )
+ else
+ Buffer.contents b
+ in
+ loop 0
+
+let is_small_file path + is_regular_file path &&
+ (stat path).st_size <= 2 * 1048 * 1024
diff --git a/daemon/utils.mli b/daemon/utils.mli
new file mode 100644
index 000000000..b399bfc00
--- /dev/null
+++ b/daemon/utils.mli
@@ -0,0 +1,72 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+val prog_exists : string -> bool
+(** Return true iff the program is found on [$PATH]. *)
+
+val udev_settle : ?filename:string -> unit -> unit
+(**
+ * LVM and other commands aren't synchronous, especially when udev is
+ * involved. eg. You can create or remove some device, but the
+ * [/dev] device node won't appear until some time later. This means
+ * that you get an error if you run one command followed by another.
+ *
+ * Use [udevadm settle] after certain commands, but don't be too
+ * fussed if it fails.
+ *
+ * The optional [?filename] passes the [udevadm settle -E filename]
+ * option, which means udevadm stops waiting as soon as the named
+ * file is created (or if it exists at the start).
+ *)
+
+val is_root_device : string -> bool
+(** Return true if this is the root (appliance) device. *)
+
+val is_root_device_stat : Unix.stats -> bool
+(** As for {!is_root_device} but operates on a statbuf instead of
+ a device name. *)
+
+val proc_unmangle_path : string -> string
+(** Reverse kernel path escaping done in fs/seq_file.c:mangle_path.
+ This is inconsistently used for /proc fields. *)
+
+type command_flag + CommandFlagFoldStdoutOnStderr
+ (** For broken external commands that send error messages to stdout
+ (hello, parted) but that don't have any useful stdout information,
+ use this flag to capture the error messages in the [stderr]
+ buffer. Nothing will be captured on stdout if you use this flag. *)
+
+val command : ?flags:command_flag list -> string -> string list ->
string
+(** Run an external command without using the shell, and collect
+ stdout and stderr separately. Returns stdout if the command
+ runs successfully.
+
+ On failure of the command, this throws an exception containing
+ the stderr from the command. *)
+
+val commandr : ?flags:command_flag list -> string -> string list ->
(int * string * string)
+(** Run an external command without using the shell, and collect
+ stdout and stderr separately.
+
+ Returns [status, stdout, stderr]. As with the C function in
+ [daemon/command.c], this strips the trailing [\n] from stderr,
+ but {b not} from stdout. *)
+
+val is_small_file : string -> bool
+(** Return true if the path is a small regular file. *)
diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index a3ac13b7c..7bb6d5143 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -72,6 +72,7 @@ daemon/blkdiscard.c
daemon/blkid.c
daemon/blockdev.c
daemon/btrfs.c
+daemon/caml-stubs.c
daemon/cap.c
daemon/checksum.c
daemon/cleanups.c
@@ -82,6 +83,8 @@ daemon/compress.c
daemon/copy.c
daemon/cpio.c
daemon/cpmv.c
+daemon/daemon-c.c
+daemon/daemon-c.h
daemon/daemon.h
daemon/dd.c
daemon/debug-bmap.c
@@ -172,6 +175,7 @@ daemon/stubs.h
daemon/swap.c
daemon/sync.c
daemon/syslinux.c
+daemon/sysroot-c.c
daemon/tar.c
daemon/truncate.c
daemon/tsk.c
diff --git a/docs/guestfs-hacking.pod b/docs/guestfs-hacking.pod
index bfbe4526d..61a49e872 100644
--- a/docs/guestfs-hacking.pod
+++ b/docs/guestfs-hacking.pod
@@ -416,6 +416,13 @@ in the C<lib/> directory.
In either case, use another function as an example of what to do.
+=item 3.
+
+As an alternative to step 2: Since libguestfs 1.38, daemon actions
+can be implemented in OCaml. You have to set the C<impl = OCaml ...>
+flag in the generator. Take a look at F<daemon/file.ml> for an
+example.
+
=back
After making these changes, use C<make> to compile.
diff --git a/generator/OCaml.ml b/generator/OCaml.ml
index 53f105198..853b41bb3 100644
--- a/generator/OCaml.ml
+++ b/generator/OCaml.ml
@@ -888,3 +888,11 @@ and generate_ocaml_function_type ?(extra_unit = false)
(ret, args, optargs) | RStructList (_, typ) -> pr "%s array"
typ
| RHashtable _ -> pr "(string * string) list"
)
+
+(* Structure definitions (again). These are used in the daemon,
+ * but it's convenient to generate them here.
+ *)
+and generate_ocaml_daemon_structs () + generate_header OCamlStyle GPLv2plus;
+
+ generate_ocaml_structure_decls ()
diff --git a/generator/OCaml.mli b/generator/OCaml.mli
index 4e79a5b5a..a36fbe02f 100644
--- a/generator/OCaml.mli
+++ b/generator/OCaml.mli
@@ -20,3 +20,4 @@ val generate_ocaml_c : unit -> unit
val generate_ocaml_c_errnos : unit -> unit
val generate_ocaml_ml : unit -> unit
val generate_ocaml_mli : unit -> unit
+val generate_ocaml_daemon_structs : unit -> unit
diff --git a/generator/actions.ml b/generator/actions.ml
index a9b3b5906..75742397a 100644
--- a/generator/actions.ml
+++ b/generator/actions.ml
@@ -185,6 +185,11 @@ let is_fish { visibility = v; style = (_, args, _) }
not (List.exists (function Pointer _ -> true | _ -> false) args)
let fish_functions = List.filter is_fish
+let is_ocaml_function = function
+ | { impl = OCaml _ } -> true
+ | { impl = C } -> false
+let impl_ocaml_functions = List.filter is_ocaml_function
+
(* In some places we want the functions to be displayed sorted
* alphabetically, so this is useful:
*)
diff --git a/generator/actions.mli b/generator/actions.mli
index 0d326b609..82217cbdc 100644
--- a/generator/actions.mli
+++ b/generator/actions.mli
@@ -40,6 +40,10 @@ val internal_functions : Types.action list -> Types.action
list
val fish_functions : Types.action list -> Types.action list
(** Filter {!actions}, returning only functions in guestfish. *)
+val impl_ocaml_functions : Types.action list -> Types.action list
+(** Filter {!actions}, returning only functions implemented
+ in OCaml (in the daemon). *)
+
val documented_functions : Types.action list -> Types.action list
(** Filter {!actions}, returning only functions requiring documentation. *)
diff --git a/generator/daemon.ml b/generator/daemon.ml
index 2ae462864..5004509e6 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -471,6 +471,324 @@ let generate_daemon_stubs actions () pr
"}\n\n";
) (actions |> daemon_functions |> sort)
+let generate_daemon_caml_types_ml () + generate_header OCamlStyle GPLv2plus
+
+let generate_daemon_caml_callbacks_ml () + generate_header OCamlStyle
GPLv2plus;
+
+ if actions |> impl_ocaml_functions <> [] then (
+ pr "let init_callbacks () =\n";
+ pr " (* Initialize callbacks to OCaml code. *)\n";
+ List.iter (
+ fun ({ name = name; style = ret, args, optargs } as f) ->
+ let ocaml_function + match f.impl with
+ | OCaml f -> f
+ | C -> assert false in
+
+ pr " Callback.register %S %s;\n" ocaml_function
ocaml_function
+ ) (actions |> impl_ocaml_functions |> sort)
+ )
+ else
+ pr "let init_callbacks () = ()\n"
+
+(* Generate stubs for the functions implemented in OCaml.
+ * Basically we implement the do_<name> function here, and
+ * have it call out to OCaml code.
+ *)
+let generate_daemon_caml_stubs () + generate_header CStyle GPLv2plus;
+
+ pr "\
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <string.h>
+#include <inttypes.h>
+#include <errno.h>
+
+#include <caml/alloc.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+#include \"daemon.h\"
+#include \"actions.h\"
+#include \"daemon-c.h\"
+
+";
+
+ (* Implement code for returning structs and struct lists. *)
+ let emit_return_struct typ + let struc = Structs.lookup_struct typ in
+ pr "/* Implement RStruct (%S, _). */\n" typ;
+ pr "static guestfs_int_%s *\n" typ;
+ pr "return_%s (value retv)\n" typ;
+ pr "{\n";
+ pr " guestfs_int_%s *ret;\n" typ;
+ pr " value v;\n";
+ pr "\n";
+ pr " ret = malloc (sizeof (*ret));\n";
+ pr " if (ret == NULL) {\n";
+ pr " reply_with_perror (\"malloc\");\n";
+ pr " return NULL;\n";
+ pr " }\n";
+ pr "\n";
+ iteri (
+ fun i ->
+ pr " v = Field (retv, %d);\n" i;
+ function
+ | n, (FString|FUUID) ->
+ pr " ret->%s = strdup (String_val (v));\n" n;
+ pr " if (ret->%s == NULL) return NULL;\n" n
+ | n, FBuffer ->
+ pr " ret->%s_len = caml_string_length (v);\n" n;
+ pr " ret->%s = strdup (String_val (v));\n" n;
+ pr " if (ret->%s == NULL) return NULL;\n" n
+ | n, (FBytes|FInt64|FUInt64) ->
+ pr " ret->%s = Int64_val (v);\n" n
+ | n, (FInt32|FUInt32) ->
+ pr " ret->%s = Int32_val (v);\n" n
+ | n, FOptPercent ->
+ pr " if (v == Val_int (0)) /* None */\n";
+ pr " ret->%s = -1;\n" n;
+ pr " else {\n";
+ pr " v = Field (v, 0);\n";
+ pr " ret->%s = Double_val (v);\n" n;
+ pr " }\n"
+ | n, FChar ->
+ pr " ret->%s = Int_val (v);\n" n
+ ) struc.s_cols;
+ pr "\n";
+ pr " return ret;\n";
+ pr "}\n";
+ pr "\n"
+
+ and emit_return_struct_list typ + pr "/* Implement RStructList (%S,
_). */\n" typ;
+ pr "static guestfs_int_%s_list *\n" typ;
+ pr "return_%s_list (value retv)\n" typ;
+ pr "{\n";
+ pr " guestfs_int_%s_list *ret;\n" typ;
+ pr " guestfs_int_%s *r;\n" typ;
+ pr " size_t i, len;\n";
+ pr " value v, rv;\n";
+ pr "\n";
+ pr " /* Count the number of elements in the list. */\n";
+ pr " rv = retv;\n";
+ pr " len = 0;\n";
+ pr " while (rv != Val_int (0)) {\n";
+ pr " len++;\n";
+ pr " rv = Field (rv, 1);\n";
+ pr " }\n";
+ pr "\n";
+ pr " ret = malloc (sizeof *ret);\n";
+ pr " if (ret == NULL) {\n";
+ pr " reply_with_perror (\"malloc\");\n";
+ pr " return NULL;\n";
+ pr " }\n";
+ pr " ret->guestfs_int_%s_list_len = len;\n" typ;
+ pr " ret->guestfs_int_%s_list_val =\n" typ;
+ pr " calloc (len, sizeof (guestfs_int_%s));\n" typ;
+ pr " if (ret->guestfs_int_%s_list_val == NULL) {\n" typ;
+ pr " reply_with_perror (\"calloc\");\n";
+ pr " free (ret);\n";
+ pr " return NULL;\n";
+ pr " }\n";
+ pr "\n";
+ pr " rv = retv;\n";
+ pr " for (i = 0; i < len; ++i) {\n";
+ pr " v = Field (rv, 0);\n";
+ pr " r = return_%s (v);\n" typ;
+ pr " if (r == NULL)\n";
+ pr " return NULL; /* XXX leaks memory along this error path
*/\n";
+ pr " memcpy (&ret->guestfs_int_%s_list_val[i], r, sizeof
(*r));\n" typ;
+ pr " free (r);\n";
+ pr " rv = Field (rv, 1);\n";
+ pr " }\n";
+ pr "\n";
+ pr " return ret;\n";
+ pr "}\n";
+ pr "\n";
+ in
+
+ List.iter (
+ function
+ | typ, RStructOnly ->
+ emit_return_struct typ
+ | typ, (RStructListOnly | RStructAndList) ->
+ emit_return_struct typ;
+ emit_return_struct_list typ
+ ) (rstructs_used_by (actions |> impl_ocaml_functions));
+
+ (* Implement the wrapper functions. *)
+ List.iter (
+ fun ({ name = name; style = ret, args, optargs } as f) ->
+ let uc_name = String.uppercase_ascii name in
+ let ocaml_function + match f.impl with
+ | OCaml f -> f
+ | C -> assert false in
+
+ pr "/* Wrapper for OCaml function ‘%s’. */\n" ocaml_function;
+
+ let args_do_function = args @ args_of_optargs optargs in
+ let args_do_function + List.filter (function
+ | String ((FileIn|FileOut), _) -> false | _ -> true)
+ args_do_function in
+ let style = ret, args_do_function, [] in
+ generate_prototype ~extern:false ~semicolon:false
+ ~single_line:false ~newline:false
+ ~in_daemon:true ~prefix:"do_"
+ name style;
+ pr "\n";
+
+ let add_unit_arg + let args = List.filter
+ (function
+ | String ((FileIn|FileOut), _) -> false | _ ->
true)
+ args in
+ args = [] in
+ let nr_args = List.length args_do_function in
+
+ pr "{\n";
+ pr " static value *cb = NULL;\n";
+ pr " CAMLparam0 ();\n";
+ pr " CAMLlocal2 (v, retv);\n";
+ pr " CAMLlocalN (args, %d);\n"
+ (nr_args + if add_unit_arg then 1 else 0);
+ pr "\n";
+ pr " if (cb == NULL)\n";
+ pr " cb = caml_named_value (\"%s\");\n"
ocaml_function;
+ pr "\n";
+
+ (* Construct the actual call, but note that we want to pass
+ * the optional arguments first in the list.
+ *)
+ let i = ref 0 in
+ List.iter (
+ fun optarg ->
+ let n = name_of_optargt optarg in
+ let uc_n = String.uppercase_ascii n in
+
+ (* optargs are all passed as [None|Some _] *)
+ pr " if ((optargs_bitmask & GUESTFS_%s_%s_BITMASK) ==
0)\n"
+ uc_name uc_n;
+ pr " args[%d] = Val_int (0); /* None */\n" !i;
+ pr " else {\n";
+ pr " v = ";
+ (match optarg with
+ | OBool _ ->
+ pr "Val_bool (%s)" n;
+ | OInt _ -> assert false
+ | OInt64 _ -> assert false
+ | OString _ -> assert false
+ | OStringList _ -> assert false
+ );
+ pr ";\n";
+ pr " args[%d] = caml_alloc (1, 0);\n" !i;
+ pr " Store_field (args[%d], 0, v);\n" !i;
+ pr " }\n";
+ incr i
+ ) optargs;
+ List.iter (
+ fun arg ->
+ pr " args[%d] = " !i;
+ (match arg with
+ | Bool n -> pr "Val_bool (%s)" n
+ | Int n -> pr "Val_int (%s)" n
+ | Int64 n -> pr "caml_copy_int64 (%s)" n
+ | String ((PlainString|Device|Pathname|Dev_or_Path), n) ->
+ pr "caml_copy_string (%s)" n
+ | String ((Mountable|Mountable_or_Path), n) ->
+ pr "guestfs_int_daemon_copy_mountable (%s)" n
+ | String _ -> assert false
+ | OptString _ -> assert false
+ | StringList _ -> assert false
+ | BufferIn _ -> assert false
+ | Pointer _ -> assert false
+ );
+ pr ";\n";
+ incr i
+ ) args;
+ assert (!i = nr_args);
+
+ (* If there are no non-optional arguments, we add a unit arg. *)
+ if add_unit_arg then
+ pr " args[%d] = Val_unit;\n" !i;
+
+ pr " retv = caml_callbackN_exn (*cb, %d, args);\n"
+ (nr_args + if add_unit_arg then 1 else 0);
+ pr "\n";
+ pr " if (Is_exception_result (retv)) {\n";
+ pr " retv = Extract_exception (retv);\n";
+ pr " guestfs_int_daemon_exn_to_reply_with_error (%S,
retv);\n" name;
+ (match errcode_of_ret ret with
+ | `CannotReturnError ->
+ pr " CAMLreturn0;\n"
+ | `ErrorIsMinusOne ->
+ pr " CAMLreturnT (int, -1);\n"
+ | `ErrorIsNULL ->
+ pr " CAMLreturnT (void *, NULL);\n"
+ );
+ pr " }\n";
+ pr "\n";
+
+ (match ret with
+ | RErr ->
+ pr " CAMLreturnT (int, 0);\n"
+ | RInt _ ->
+ pr " CAMLreturnT (int, Int_val (retv));\n"
+ | RInt64 _ ->
+ pr " CAMLreturnT (int, Int64_val (retv));\n"
+ | RBool _ ->
+ pr " CAMLreturnT (int, Bool_val (retv));\n"
+ | RConstString _ -> assert false
+ | RConstOptString _ -> assert false
+ | RString ((RPlainString|RDevice), _) ->
+ pr " char *ret = strdup (String_val (retv));\n";
+ pr " if (ret == NULL) {\n";
+ pr " reply_with_perror (\"strdup\");\n";
+ pr " CAMLreturnT (char *, NULL);\n";
+ pr " }\n";
+ pr " CAMLreturnT (char *, ret); /* caller frees */\n"
+ | RString (RMountable, _) ->
+ pr " char *ret =\n";
+ pr " guestfs_int_daemon_return_string_mountable
(retv);\n";
+ pr " CAMLreturnT (char *, ret); /* caller frees */\n"
+ | RStringList _ ->
+ pr " char **ret = guestfs_int_daemon_return_string_list
(retv);\n";
+ pr " CAMLreturnT (char **, ret); /* caller frees */\n"
+ | RStruct (_, typ) ->
+ pr " guestfs_int_%s *ret =\n" typ;
+ pr " return_%s (retv);\n" typ;
+ pr " /* caller frees */\n";
+ pr " CAMLreturnT (guestfs_int_%s *, ret);\n" typ
+ | RStructList (_, typ) ->
+ pr " guestfs_int_%s_list *ret =\n" typ;
+ pr " return_%s_list (retv);\n" typ;
+ pr " /* caller frees */\n";
+ pr " CAMLreturnT (guestfs_int_%s_list *, ret);\n" typ
+ | RHashtable (RPlainString, RPlainString, _) ->
+ pr " char **ret =\n";
+ pr " guestfs_int_daemon_return_hashtable_string_string
(retv);\n";
+ pr " CAMLreturnT (char **, ret); /* caller frees */\n"
+ | RHashtable (RMountable, RPlainString, _) ->
+ pr " char **ret =\n";
+ pr " guestfs_int_daemon_return_hashtable_mountable_string
(retv);\n";
+ pr " CAMLreturnT (char **, ret); /* caller frees */\n"
+ | RHashtable _ -> assert false
+ | RBufferOut _ -> assert false
+ );
+ pr "}\n";
+ pr "\n"
+ ) (actions |> impl_ocaml_functions |> sort)
+
let generate_daemon_dispatch () generate_header CStyle GPLv2plus;
@@ -730,6 +1048,8 @@ let generate_daemon_optgroups_c ()
pr "#include <config.h>\n";
pr "\n";
+ pr "#include <caml/mlvalues.h>\n";
+ pr "\n";
pr "#include \"daemon.h\"\n";
pr "#include \"optgroups.h\"\n";
pr "\n";
@@ -752,7 +1072,22 @@ let generate_daemon_optgroups_c () pr " {
\"%s\", optgroup_%s_available },\n" group group
) optgroups_names_all;
pr " { NULL, NULL }\n";
- pr "};\n"
+ pr "};\n";
+ pr "\n";
+ pr "/* Wrappers so these functions can be called from OCaml code.
*/\n";
+ List.iter (
+ fun group ->
+ pr "extern value guestfs_int_daemon_optgroup_%s_available
(value);\n"
+ group;
+ pr "\n";
+ pr "/* NB: This is a \"noalloc\" call. */\n";
+ pr "value\n";
+ pr "guestfs_int_daemon_optgroup_%s_available (value unitv)\n"
group;
+ pr "{\n";
+ pr " return Val_bool (optgroup_%s_available ());\n" group;
+ pr "}\n";
+ pr "\n"
+ ) optgroups_names
let generate_daemon_optgroups_h () generate_header CStyle GPLv2plus;
diff --git a/generator/daemon.mli b/generator/daemon.mli
index ff008bf85..314a6da8f 100644
--- a/generator/daemon.mli
+++ b/generator/daemon.mli
@@ -19,6 +19,9 @@
val generate_daemon_actions_h : unit -> unit
val generate_daemon_stubs_h : unit -> unit
val generate_daemon_stubs : Types.action list -> unit -> unit
+val generate_daemon_caml_stubs : unit -> unit
+val generate_daemon_caml_callbacks_ml : unit -> unit
+val generate_daemon_caml_types_ml : unit -> unit
val generate_daemon_dispatch : unit -> unit
val generate_daemon_lvm_tokenization : unit -> unit
val generate_daemon_names : unit -> unit
diff --git a/generator/main.ml b/generator/main.ml
index c8890de6a..c61326b61 100644
--- a/generator/main.ml
+++ b/generator/main.ml
@@ -133,6 +133,12 @@ Run it from the top source directory using the command
Daemon.generate_daemon_stubs_h;
output_to_subset "daemon/stubs-%d.c"
Daemon.generate_daemon_stubs;
+ output_to "daemon/caml-stubs.c"
+ Daemon.generate_daemon_caml_stubs;
+ output_to "daemon/callbacks.ml"
+ Daemon.generate_daemon_caml_callbacks_ml;
+ output_to "daemon/types.ml"
+ Daemon.generate_daemon_caml_types_ml;
output_to "daemon/dispatch.c"
Daemon.generate_daemon_dispatch;
output_to "daemon/names.c"
@@ -185,6 +191,8 @@ Run it from the top source directory using the command
OCaml.generate_ocaml_c;
output_to "ocaml/guestfs-c-errnos.c"
OCaml.generate_ocaml_c_errnos;
+ output_to "daemon/structs.ml"
+ OCaml.generate_ocaml_daemon_structs;
output_to "ocaml/bindtests.ml"
Bindtests.generate_ocaml_bindtests;
diff --git a/generator/types.ml b/generator/types.ml
index 740bc7750..fb6c3bc06 100644
--- a/generator/types.ml
+++ b/generator/types.ml
@@ -379,11 +379,16 @@ type deprecated_by | Replaced_by of string (*
replaced by another function *)
| Deprecated_no_replacement (* deprecated with no replacement *)
+type impl + | C (* implemented in C by
"do_<name>" *)
+ | OCaml of string (* implemented in OCaml by named function *)
+
(* Type of an action as declared in Actions module. *)
type action = {
name : string; (* name, not including "guestfs_"
*)
added : version; (* which version was the API first added *)
style : style; (* args and return value *)
+ impl : impl; (* implementation language (C or OCaml) *)
proc_nr : int option; (* proc number, None for non-daemon *)
tests : c_api_tests; (* C API tests *)
test_excuse : string; (* if there's no tests ... *)
@@ -439,7 +444,7 @@ type action = {
*)
let defaults = { name = "";
added = (-1,-1,-1);
- style = RErr, [], []; proc_nr = None;
+ style = RErr, [], []; impl = C; proc_nr = None;
tests = []; test_excuse = "";
shortdesc = ""; longdesc = "";
protocol_limit_warning = false; fish_alias = [];
--
2.13.2
Richard W.M. Jones
2017-Jul-21 20:36 UTC
[Libguestfs] [PATCH v2 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 | 80 -----------------------------------------------
daemon/file.ml | 59 ++++++++++++++++++++++++++++++++++
daemon/file.mli | 19 +++++++++++
generator/actions_core.ml | 1 +
5 files changed, 81 insertions(+), 80 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 67a26de06..7d8e84aeb 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 = \
@@ -251,6 +252,7 @@ SOURCES_ML = \
structs.ml \
sysroot.ml \
chroot.ml \
+ file.ml \
callbacks.ml \
daemon.ml
diff --git a/daemon/file.c b/daemon/file.c
index 84874dc6f..ee79eb507 100644
--- a/daemon/file.c
+++ b/daemon/file.c
@@ -30,7 +30,6 @@
#include "actions.h"
#include "optgroups.h"
-GUESTFSD_EXT_CMD(str_file, file);
GUESTFSD_EXT_CMD(str_zcat, zcat);
GUESTFSD_EXT_CMD(str_bzcat, bzcat);
@@ -449,85 +448,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, str_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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 7d8e84aeb..3c3ad5c97 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 = \
@@ -251,7 +253,9 @@ SOURCES_ML = \
utils.ml \
structs.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 1fe5ff93a..7757b5ad0 100644
--- a/daemon/blkid.c
+++ b/daemon/blkid.c
@@ -69,12 +69,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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 | 3 -
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(+), 335 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 3c3ad5c97..d75413e66 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
@@ -256,6 +257,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 be7a3bedc..0a92e6cee 100644
--- a/daemon/daemon.h
+++ b/daemon/daemon.h
@@ -130,9 +130,6 @@ extern void free_stringsbuf (struct stringsbuf *sb);
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 struct stringsbuf split_lines_sb (char *str);
extern char **split_lines (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 ddc49ed44..a302c3d5c 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 347ed613b..ecbf924d5 100644
--- a/daemon/utils.ml
+++ b/daemon/utils.ml
@@ -133,6 +133,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 b399bfc00..d3c8bdf4d 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-21 20:36 UTC
[Libguestfs] [PATCH v2 05/23] daemon: Add unit tests of the ‘Utils’ module.
---
.gitignore | 1 +
daemon/Makefile.am | 43 ++++++++++++++++++++++++++++++++++++++-
daemon/daemon_utils_tests.ml | 48 ++++++++++++++++++++++++++++++++++++++++++++
daemon/dummy.c | 2 ++
docs/C_SOURCE_FILES | 1 +
5 files changed, 94 insertions(+), 1 deletion(-)
diff --git a/.gitignore b/.gitignore
index 4f10327c4..c553141e9 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 d75413e66..8ffa35ec5 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
@@ -268,7 +269,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)
@@ -295,6 +297,45 @@ camldaemon.o: $(OBJECTS)
-linkpkg mlcutils.$(MLARCHIVE) mlstdutils.$(MLARCHIVE) \
$(OBJECTS)
+# Unit tests.
+
+check_PROGRAMS = daemon_utils_tests
+TESTS = daemon_utils_tests
+
+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 $@
+
+check-valgrind:
+ $(MAKE) VG="@VG@" check
+
# OCaml dependencies.
depend: .depend
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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 8ffa35ec5..3c9cc1c71 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
@@ -260,6 +261,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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 3c9cc1c71..74ccc4c6f 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
@@ -262,6 +263,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 3ce54fa37..dde61a1c2 100644
--- a/daemon/link.c
+++ b/daemon/link.c
@@ -32,22 +32,6 @@
GUESTFSD_EXT_CMD(str_ln, ln);
-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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 | 43 ++++++++++++++++++++
daemon/daemon.h | 6 ---
daemon/mount.c | 99 -----------------------------------------------
daemon/mount.ml | 62 +++++++++++++++++++++++++++++
daemon/mount.mli | 22 +++++++++++
generator/actions_core.ml | 4 ++
7 files changed, 133 insertions(+), 105 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 74ccc4c6f..1ac48f751 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
@@ -264,6 +265,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 5f1e5d1d0..4f52b71e8 100644
--- a/daemon/btrfs.c
+++ b/daemon/btrfs.c
@@ -37,6 +37,7 @@ GUESTFSD_EXT_CMD(str_btrfs, btrfs);
GUESTFSD_EXT_CMD(str_btrfstune, btrfstune);
GUESTFSD_EXT_CMD(str_btrfsck, btrfsck);
GUESTFSD_EXT_CMD(str_mkfs_btrfs, mkfs.btrfs);
+GUESTFSD_EXT_CMD(str_mount, mount);
GUESTFSD_EXT_CMD(str_umount, umount);
GUESTFSD_EXT_CMD(str_btrfsimage, btrfs-image);
@@ -387,6 +388,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,
+ str_mount, "-o", options_plus ? options_plus :
options,
+ "-t", vfstype, device, mp, NULL);
+ else
+ r = command (NULL, &error,
+ str_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 0a92e6cee..62e1211c8 100644
--- a/daemon/daemon.h
+++ b/daemon/daemon.h
@@ -94,12 +94,6 @@ extern void cleanup_free_stringsbuf (void *ptr);
#define CLEANUP_FREE_STRINGSBUF
#endif
-/*-- in mount.c --*/
-
-extern int mount_vfs_nochroot (const char *options, const char *vfstype,
- const mountable_t *mountable,
- const char *mp, const char *user_mp);
-
/* Growable strings buffer. */
struct stringsbuf {
char **argv;
diff --git a/daemon/mount.c b/daemon/mount.c
index 0ad9626a7..962b86079 100644
--- a/daemon/mount.c
+++ b/daemon/mount.c
@@ -111,105 +111,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,
- str_mount, "-o", options_plus ? options_plus :
options,
- "-t", vfstype, device, mp, NULL);
- else
- r = command (NULL, &error,
- str_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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 1ac48f751..b69fc8c5b 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 = \
@@ -266,6 +267,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 03e83cb32..a1e5c81cf 100644
--- a/daemon/parted.c
+++ b/daemon/parted.c
@@ -521,48 +521,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, str_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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 b69fc8c5b..cf622a705 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 = \
@@ -268,6 +269,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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 cf622a705..6d6e1b962 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 \
@@ -265,6 +266,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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 6d6e1b962..f1ab10c6e 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 \
@@ -268,6 +269,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 75418e8d3..5106e65f9 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>
@@ -47,87 +46,6 @@ optgroup_ldm_available (void)
return prog_exists (str_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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 f1ab10c6e..2a8e5876a 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 \
@@ -271,6 +272,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 5d12b009f..072bf53b4 100644
--- a/daemon/lvm.c
+++ b/daemon/lvm.c
@@ -103,89 +103,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)
{
@@ -222,74 +139,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, str_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,
- str_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,
- str_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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 2a8e5876a..d017f73eb 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 \
@@ -273,6 +274,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 64d98fae5..5c9ecd136 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"
@@ -45,6 +46,35 @@ optgroup_mdadm_available (void)
return prog_exists (str_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)
{
@@ -188,99 +218,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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 | 126 +++++++++++++++++++++++++++++++++
daemon/btrfs.mli | 26 +++++++
generator/actions_core.ml | 2 +
5 files changed, 156 insertions(+), 175 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index d017f73eb..94e8e0417 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 \
@@ -267,6 +268,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 4f52b71e8..d9043d53c 100644
--- a/daemon/btrfs.c
+++ b/daemon/btrfs.c
@@ -41,11 +41,6 @@ GUESTFSD_EXT_CMD(str_mount, mount);
GUESTFSD_EXT_CMD(str_umount, umount);
GUESTFSD_EXT_CMD(str_btrfsimage, btrfs-image);
-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
@@ -483,137 +478,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, str_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)
{
@@ -649,45 +513,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, str_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..01484adab
--- /dev/null
+++ b/daemon/btrfs.ml
@@ -0,0 +1,126 @@
+(* 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 + 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
+
+and _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)
+
+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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 | 3 +
daemon/ldm.mli | 2 +
daemon/listfs.ml | 159 ++++++++++++++++++++++++++++++
daemon/listfs.mli | 19 ++++
daemon/lvm.ml | 3 +
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, 230 insertions(+), 286 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 94e8e0417..d6a7ae544 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 \
@@ -279,6 +280,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..dd736cc1f 100644
--- a/daemon/ldm.ml
+++ b/daemon/ldm.ml
@@ -20,6 +20,9 @@ open Std_utils
open Utils
+external available : unit -> bool +
"guestfs_int_daemon_optgroup_lvm2_available" "noalloc"
+
(* 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..b19bf93fd 100644
--- a/daemon/lvm.ml
+++ b/daemon/lvm.ml
@@ -22,6 +22,9 @@ open Std_utils
open Utils
+external available : unit -> bool +
"guestfs_int_daemon_optgroup_lvm2_available" "noalloc"
+
(* 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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 a1e5c81cf..125aec60b 100644
--- a/daemon/parted.c
+++ b/daemon/parted.c
@@ -387,62 +387,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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 | 94 -----------------------------------------------
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(+), 96 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index d6a7ae544..91eb9c08e 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 \
@@ -277,6 +277,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 f44137038..000000000
--- a/daemon/findfs.c
+++ /dev/null
@@ -1,94 +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"
-
-GUESTFSD_EXT_CMD(str_findfs, findfs);
-
-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, str_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 b19bf93fd..00d5fff8d 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
@@ -99,3 +100,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-21 20:36 UTC
[Libguestfs] [PATCH v2 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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 5c9ecd136..549dd89fa 100644
--- a/daemon/md.c
+++ b/daemon/md.c
@@ -218,72 +218,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[] = { str_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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 91eb9c08e..5d6752c90 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-21 20:36 UTC
[Libguestfs] [PATCH v2 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 125aec60b..1c81cd968 100644
--- a/daemon/parted.c
+++ b/daemon/parted.c
@@ -348,45 +348,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)
{
@@ -557,126 +518,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,
- str_sgdisk, device, "-i", partnum_str, NULL);
-
- if (r == -1) {
- reply_with_error ("%s %s -i %s: %s", str_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",
- str_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)
{
@@ -840,6 +681,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..9131718a2 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 ~flags:[CommandFlagFoldStdoutOnStderr]
+ "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-21 20:36 UTC
[Libguestfs] [PATCH v2 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
Pino Toscano
2017-Jul-27 16:15 UTC
Re: [Libguestfs] [PATCH v2 00/23] Reimplement many daemon APIs in OCaml.
On Friday, 21 July 2017 22:36:04 CEST Richard W.M. Jones wrote:> v1 -> v2: > > - [lots of changes]Thanks for them.> Requested, but not done for various reasons: > > - Removing GUESTFSD_EXT_CMD. This is still being used by OpenSUSE, so > we'll have to think of a better mechanism for it. Something like > ‘guestfsd --dump-commands’ may work better.Note I was not suggesting to remove it unconditionally, but that the C -> OCaml conversion would have lost some of them -- thus find a solution to make the list of used tools still coherent (i.e for both C and OCaml code), or remove it altogether. This is now dealt by removing it.> - Generating: > external available : unit -> bool = "guestfs_int_daemon_optgroup..." > etc. It's hard to generate these functions and have them added to the > correct modules (since the OCaml modules are hand-written, and it's > awkward to include generated bits in them).My suggestion was to create a single OptGroups module, with all the foo_available functions. Instead of all the functions, another option could be like the following: type available_feature | ACL | AUGEAS ... val available : available_feature -> bool> Other notes: > > - daemon must be linked to -ldl -lm because the OCaml runtime > (libasmrun.so) depends on both.I don't understand, at least here it links with them: $ readelf -d /usr/lib64/ocaml/libasmrun_shared.so | grep NEEDED 0x0000000000000001 (NEEDED) Shared library: [libm.so.6] 0x0000000000000001 (NEEDED) Shared library: [libdl.so.2] 0x0000000000000001 (NEEDED) Shared library: [libc.so.6] So unless we use libdl and libm explicitly, we don't need to care about which libraries are used by libasmrun.so. Am I missing anything here?> - Structs must be repeated in *.mli files because you can't use OCaml > ‘include’ to pick up single structs from another module. However > the structs are still type checked by the compiler, so we cannot > write incorrect / untyped code this way.Not even by referencing the module? Ie. Structs.btrfsvolumeinfo (or so), like done eg in builder/*_parser.mli? -- Pino Toscano
Pino Toscano
2017-Jul-27 16:17 UTC
Re: [Libguestfs] [PATCH v2 01/23] daemon: Allow parts of the daemon and APIs to be written in OCaml.
On Friday, 21 July 2017 22:36:05 CEST Richard W.M. Jones wrote:> +let commandr ?(flags = []) prog args > + let fold_stdout_on_stderr = List.mem CommandFlagFoldStdoutOnStderr flags in > + > + if verbose () then > + eprintf "command: %s %s\n%!" > + (if fold_stdout_on_stderr then " fold-stdout-on-stderr" else "") > + (stringify_args (prog :: args)); > + > + let argv = Array.of_list (prog :: args) in > + > + let stdout_file, stdout_chan = Filename.open_temp_file "cmd" ".out" in > + let stderr_file, stderr_chan = Filename.open_temp_file "cmd" ".err" inThese temporary files ought to be removed, otherwise they pile up within the daemon, and also when the process fails (i.e. when issuing failwithf).> +type command_flag > + CommandFlagFoldStdoutOnStderr > + (** For broken external commands that send error messages to stdout > + (hello, parted) but that don't have any useful stdout information, > + use this flag to capture the error messages in the [stderr] > + buffer. Nothing will be captured on stdout if you use this flag. *)Given command* do not wrap the C functions, what about using labelled optional arguments instead of the above? Thanks, -- Pino Toscano
Pino Toscano
2017-Jul-27 16:18 UTC
Re: [Libguestfs] [PATCH v2 15/23] daemon: Reimplement ‘btrfs_subvolume_list’ and ‘btrfs_subvolume_get_default’ in OCaml.
On Friday, 21 July 2017 22:36:19 CEST Richard W.M. Jones wrote:> +let rec with_mounted mountable f > + 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 > + > +and _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)As minor note: this subhelper (_with_mounted) could be moved inside with_mounted, so there is no risk to use it "accidentally" elsewhere in btrfs.ml. (Yes, I know the parameters are different, so a '_' typo would give a build error, but you can get what I mean here.) Thanks, -- Pino Toscano
Richard W.M. Jones
2017-Jul-27 16:44 UTC
Re: [Libguestfs] [PATCH v2 00/23] Reimplement many daemon APIs in OCaml.
On Thu, Jul 27, 2017 at 06:15:28PM +0200, Pino Toscano wrote:> On Friday, 21 July 2017 22:36:04 CEST Richard W.M. Jones wrote: > > - Generating: > > external available : unit -> bool = "guestfs_int_daemon_optgroup..." > > etc. It's hard to generate these functions and have them added to the > > correct modules (since the OCaml modules are hand-written, and it's > > awkward to include generated bits in them). > > My suggestion was to create a single OptGroups module, with all the > foo_available functions. Instead of all the functions, another option > could be like the following: > > type available_feature > | ACL > | AUGEAS > ... > > val available : available_feature -> boolOK maybe we can fix that later as it only affects 2 modules.> > Other notes: > > > > - daemon must be linked to -ldl -lm because the OCaml runtime > > (libasmrun.so) depends on both. > > I don't understand, at least here it links with them: > > $ readelf -d /usr/lib64/ocaml/libasmrun_shared.so | grep NEEDED > 0x0000000000000001 (NEEDED) Shared library: [libm.so.6] > 0x0000000000000001 (NEEDED) Shared library: [libdl.so.2] > 0x0000000000000001 (NEEDED) Shared library: [libc.so.6] > > So unless we use libdl and libm explicitly, we don't need to care about > which libraries are used by libasmrun.so. Am I missing anything here?We're linking with the static runtime (libasmrun.a). Now we certainly could link with the shared runtime but that would pull the OCaml compiler into the appliance, or at least it would with the current state of the packaging on Fedora. Also libasmrun_shared is only supported in OCaml >= 4.02 [https://caml.inria.fr/mantis/view.php?id=6693] The shared runtime is slower because of something to do with ELF which I don't exactly recall now.> > - Structs must be repeated in *.mli files because you can't use OCaml > > ‘include’ to pick up single structs from another module. However > > the structs are still type checked by the compiler, so we cannot > > write incorrect / untyped code this way. > > Not even by referencing the module? Ie. Structs.btrfsvolumeinfo > (or so), like done eg in builder/*_parser.mli?Sure we could reference it, but in this case I'm actually (re-)exporting the structs from the module, so that when calling these functions from other parts of the daemon you could write: (Btrfs.btrfs_subvolume_list m).Btrfs.btrfssubvolume_id Maybe that's not a very good reason, but that's the reason. Rich. -- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones Read my programming and virtualization blog: http://rwmj.wordpress.com virt-top is 'top' for virtual machines. Tiny program with many powerful monitoring features, net stats, disk stats, logging, etc. http://people.redhat.com/~rjones/virt-top
Possibly Parallel Threads
- [PATCH 02/27] daemon: Allow parts of the daemon and APIs to be written in OCaml.
- [PATCH 19/27] daemon: Reimplement ‘list_filesystems’ API in the daemon, in OCaml.
- [PATCH 04/27] daemon: Reimplement ‘vfs_type’ API in OCaml.
- [PATCH 23/27] daemon: Reimplement ‘md_detail’ API in OCaml.
- [PATCH v11 02/10] daemon: Embed the ocaml-augeas library in the daemon.