Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 00/27] Reimplement many daemon APIs in OCaml.
Previously posted as part of the mega utilities/inspection series here: https://www.redhat.com/archives/libguestfs/2017-June/msg00232.html What I've done is to extract just the parts related to rewriting daemon APIs in OCaml, rebase them on top of the current master, fix a few things, and recompile and test everything. Rich.
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 01/27] build: Make OCaml compiler required for all builds.
Previously the OCaml compiler was only required if building from git
but was at least theoretically optional if building from tarballs
(although this was never tested). Since we want to write parts of the
daemon in OCaml, this makes OCaml required for all builds.
Note that the ‘--disable-ocaml’ option remains, but it now only
disables OCaml bindings and OCaml virt tools. Using this option does
not disable the OCaml compiler requirement.
Also note that ‘HAVE_OCAML’ changes meaning slightly, so it now means
"build OCaml bindings and tools" (analogous to ‘HAVE_PERL’ and
others). The generator, daemon [in a future commit], and some utility
libraries needed by the generator or daemon do not test for this macro
because we can assume OCaml compiler availability.
---
common/mlstdutils/Makefile.am | 4 ---
docs/guestfs-building.pod | 11 +++---
generator/Makefile.am | 15 --------
m4/guestfs_ocaml.m4 | 83 +++++++++++++++++++++----------------------
4 files changed, 47 insertions(+), 66 deletions(-)
diff --git a/common/mlstdutils/Makefile.am b/common/mlstdutils/Makefile.am
index 9e0b34d42..303c87c93 100644
--- a/common/mlstdutils/Makefile.am
+++ b/common/mlstdutils/Makefile.am
@@ -33,8 +33,6 @@ SOURCES_ML = \
stringMap.ml \
std_utils.ml
-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.
@@ -146,6 +144,4 @@ depend: .depend
-include .depend
-endif
-
.PHONY: depend docs
diff --git a/docs/guestfs-building.pod b/docs/guestfs-building.pod
index 0f9ed2893..80693e22e 100644
--- a/docs/guestfs-building.pod
+++ b/docs/guestfs-building.pod
@@ -120,8 +120,7 @@ I<Required>. Part of Perl core.
=item OCaml findlib
-I<Required> if compiling from git.
-Optional (but recommended) if compiling from tarball.
+I<Required>.
=item autoconf
@@ -594,8 +593,12 @@ See L</USING A PREBUILT BINARY APPLIANCE> below.
Disable specific language bindings, even if C<./configure> finds all
the necessary libraries are installed so that they could be compiled.
-Note that disabling OCaml or Perl will have the knock-on effect of
-disabling large numbers of virt tools and parts of the test suite.
+Note that disabling OCaml (bindings) or Perl will have the knock-on
+effect of disabling parts of the test suite and some tools.
+
+OCaml is required to build libguestfs and this requirement cannot be
+removed. Using I<--disable-ocaml> only disables the bindings and
+OCaml tools.
=item B<--disable-fuse>
diff --git a/generator/Makefile.am b/generator/Makefile.am
index 3f54ad51d..344ba9bcb 100644
--- a/generator/Makefile.am
+++ b/generator/Makefile.am
@@ -177,8 +177,6 @@ OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR)
noinst_PROGRAM = generator
-if HAVE_OCAML
-
generator: $(objects)
$(OCAMLFIND) ocamlc $(OCAMLFLAGS) $(OCAMLPACKAGES) -linkpkg $^ -o $@
@@ -196,19 +194,6 @@ depend: .depend
-include .depend
-else
-
-# No OCaml compiler. Just replace the generator with a script that
-# prints a warning.
-
-generator:
- rm -f $@ $@-t
- echo 'echo Warning: Install OCaml compiler in order to rebuild the
generated files.' > $@-t
- chmod +x $@-t
- mv $@-t $@
-
-endif
-
noinst_DATA = stamp-generator
# Run the generator.
diff --git a/m4/guestfs_ocaml.m4 b/m4/guestfs_ocaml.m4
index c18a3de40..a5118c9fa 100644
--- a/m4/guestfs_ocaml.m4
+++ b/m4/guestfs_ocaml.m4
@@ -15,55 +15,52 @@
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-dnl Check for OCaml (optional, for OCaml bindings and OCaml tools).
-OCAMLC=no
-OCAMLFIND=no
+dnl Check for OCaml (required, for OCaml bindings and OCaml tools).
+
+dnl OCAMLC and OCAMLFIND have to be unset first, otherwise
+dnl AC_CHECK_TOOL (inside AC_PROG_OCAML) will not look.
+OCAMLC+OCAMLFIND+AC_PROG_OCAML
+AC_PROG_FINDLIB
+
+AS_IF([test "x$OCAMLC" = "xno"],[
+ AC_MSG_ERROR([OCaml compiler is required])
+])
+
+AS_IF([test "x$OCAMLFIND" = "xno"],[
+ AC_MSG_ERROR([OCaml findlib is required])
+])
+
+dnl --disable-ocaml only disables OCaml bindings and OCaml virt tools.
AC_ARG_ENABLE([ocaml],
- AS_HELP_STRING([--disable-ocaml], [disable OCaml language bindings]),
+ AS_HELP_STRING([--disable-ocaml], [disable OCaml language bindings and
tools]),
[],
[enable_ocaml=yes])
-AS_IF([test "x$enable_ocaml" != "xno"],[
- dnl OCAMLC and OCAMLFIND have to be unset first, otherwise
- dnl AC_CHECK_TOOL (inside AC_PROG_OCAML) will not look.
- OCAMLC- OCAMLFIND- AC_PROG_OCAML
- AC_PROG_FINDLIB
- dnl OCaml >= 3.11 is required.
- AC_MSG_CHECKING([if OCaml version >= 3.11])
- ocaml_major="`echo $OCAMLVERSION | $AWK -F. '{print
$1}'`"
- ocaml_minor="`echo $OCAMLVERSION | $AWK -F. '{print
$2}'`"
- AS_IF([test "$ocaml_major" -ge 4 || ( test
"$ocaml_major" -eq 3 && test "$ocaml_minor" -ge 11
)],[
- AC_MSG_RESULT([yes])
- ],[
- AC_MSG_RESULT([no])
- AC_MSG_FAILURE([OCaml compiler is not new enough. At least OCaml 3.11
is required])
- ])
+dnl OCaml >= 3.11 is required.
+AC_MSG_CHECKING([if OCaml version >= 3.11])
+ocaml_major="`echo $OCAMLVERSION | $AWK -F. '{print $1}'`"
+ocaml_minor="`echo $OCAMLVERSION | $AWK -F. '{print $2}'`"
+AS_IF([test "$ocaml_major" -ge 4 || ( test "$ocaml_major"
-eq 3 && test "$ocaml_minor" -ge 11 )],[
+ AC_MSG_RESULT([yes])
+],[
+ AC_MSG_RESULT([no])
+ AC_MSG_FAILURE([OCaml compiler is not new enough. At least OCaml 3.11 is
required])
])
+
AM_CONDITIONAL([HAVE_OCAML],
- [test "x$OCAMLC" != "xno" && test
"x$OCAMLFIND" != "xno"])
+ [test "x$enable_ocaml" != "xno"])
AM_CONDITIONAL([HAVE_OCAMLOPT],
- [test "x$OCAMLOPT" != "xno" && test
"x$OCAMLFIND" != "xno"])
+ [test "x$OCAMLOPT" != "xno"])
AM_CONDITIONAL([HAVE_OCAMLDOC],
[test "x$OCAMLDOC" != "xno"])
-dnl OCaml is required if we need to run the generator.
-AS_IF([test "x$OCAMLC" = "xno" || test
"x$OCAMLFIND" = "xno"],[
- AS_IF([! test -f $srcdir/common/protocol/guestfs_protocol.x],[
- AC_MSG_FAILURE([OCaml compiler and findlib is required to build from
git.
-If you don't have OCaml available, you should build from a tarball from
-http://libguestfs.org/download])
- ])
-])
-
-AS_IF([test "x$OCAMLC" != "xno"],[
- dnl Check for <caml/unixsupport.h> header.
- old_CPPFLAGS="$CPPFLAGS"
- CPPFLAGS="$CPPFLAGS -I`$OCAMLC -where`"
- AC_CHECK_HEADERS([caml/unixsupport.h],[],[],[#include
<caml/mlvalues.h>])
- CPPFLAGS="$old_CPPFLAGS"
-])
+dnl Check for <caml/unixsupport.h> header.
+old_CPPFLAGS="$CPPFLAGS"
+CPPFLAGS="$CPPFLAGS -I`$OCAMLC -where`"
+AC_CHECK_HEADERS([caml/unixsupport.h],[],[],[#include <caml/mlvalues.h>])
+CPPFLAGS="$old_CPPFLAGS"
OCAML_PKG_gettext=no
OCAML_PKG_libvirt=no
@@ -102,15 +99,15 @@ AS_IF([test "x$OCAMLC" != "xno"],[
fi
])
AM_CONDITIONAL([HAVE_OCAML_PKG_GETTEXT],
- [test "x$OCAMLC" != "xno" && test
"x$OCAMLFIND" != "xno" && test
"x$OCAML_PKG_gettext" != "xno"])
+ [test "x$OCAML_PKG_gettext" != "xno"])
AM_CONDITIONAL([HAVE_OCAML_PKG_LIBVIRT],
- [test "x$OCAMLC" != "xno" && test
"x$OCAMLFIND" != "xno" && test
"x$OCAML_PKG_libvirt" != "xno"])
+ [test "x$OCAML_PKG_libvirt" != "xno"])
AM_CONDITIONAL([HAVE_OCAML_PKG_OUNIT],
- [test "x$OCAMLC" != "xno" && test
"x$OCAMLFIND" != "xno" && test
"x$OCAML_PKG_oUnit" != "xno" && test
"x$ounit_is_v2" != "xno"])
+ [test "x$OCAML_PKG_oUnit" != "xno"
&& test "x$ounit_is_v2" != "xno"])
AC_CHECK_PROG([OCAML_GETTEXT],[ocaml-gettext],[ocaml-gettext],[no])
AM_CONDITIONAL([HAVE_OCAML_GETTEXT],
- [test "x$OCAMLC" != "xno" && test
"x$OCAMLFIND" != "xno" && test
"x$OCAML_PKG_gettext" != "xno" && test
"x$OCAML_GETTEXT" != "xno"])
+ [test "x$OCAML_PKG_gettext" != "xno"
&& test "x$OCAML_GETTEXT" != "xno"])
dnl Create the backwards compatibility Bytes module for OCaml < 4.02.
mkdir -p common/mlstdutils
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 02/27] 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 | 6 +-
Makefile.am | 2 +-
common/mlutils/Makefile.am | 4 -
daemon/Makefile.am | 103 +++++++++++++++++++++++--
daemon/chroot.ml | 85 +++++++++++++++++++++
daemon/chroot.mli | 35 +++++++++
daemon/daemon-c.c | 35 +++++++++
daemon/daemon.ml | 39 ++++++++++
daemon/guestfsd.c | 50 ++++++++++++
daemon/sysroot-c.c | 37 +++++++++
daemon/sysroot.ml | 19 +++++
daemon/sysroot.mli | 22 ++++++
daemon/utils.ml | 156 +++++++++++++++++++++++++++++++++++++
daemon/utils.mli | 65 ++++++++++++++++
docs/guestfs-hacking.pod | 7 ++
generator/actions.ml | 5 ++
generator/actions.mli | 4 +
generator/daemon.ml | 187 +++++++++++++++++++++++++++++++++++++++++++++
generator/daemon.mli | 3 +
generator/main.ml | 6 ++
generator/types.ml | 7 +-
21 files changed, 865 insertions(+), 12 deletions(-)
diff --git a/.gitignore b/.gitignore
index bbd9284c6..815431b7b 100644
--- a/.gitignore
+++ b/.gitignore
@@ -165,20 +165,24 @@ 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/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..40b770762 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -19,6 +19,7 @@ include $(top_srcdir)/subdir-rules.mk
generator_built = \
actions.h \
+ caml-stubs.c \
dispatch.c \
names.c \
lvm-tokenization.c \
@@ -31,13 +32,30 @@ generator_built = \
stubs-4.c \
stubs-5.c \
stubs-6.c \
- stubs.h
+ stubs.h \
+ callbacks.ml \
+ types.ml
BUILT_SOURCES = \
- $(generator_built)
+ actions.h \
+ caml-stubs.c \
+ dispatch.c \
+ names.c \
+ lvm-tokenization.c \
+ structs-cleanups.c \
+ structs-cleanups.h \
+ stubs-0.c \
+ stubs-1.c \
+ stubs-2.c \
+ stubs-3.c \
+ stubs-4.c \
+ stubs-5.c \
+ stubs-6.c \
+ stubs.h
EXTRA_DIST = \
- $(BUILT_SOURCES) \
+ $(generator_built) \
+ $(SOURCES_MLI) $(SOURCES_ML) \
guestfsd.pod
if INSTALL_DAEMON
@@ -61,6 +79,7 @@ guestfsd_SOURCES = \
blkid.c \
blockdev.c \
btrfs.c \
+ caml-stubs.c \
cap.c \
checksum.c \
cleanups.c \
@@ -71,6 +90,7 @@ guestfsd_SOURCES = \
copy.c \
cpio.c \
cpmv.c \
+ daemon-c.c \
daemon.h \
dd.c \
debug.c \
@@ -161,6 +181,7 @@ guestfsd_SOURCES = \
swap.c \
sync.c \
syslinux.c \
+ sysroot-c.c \
tar.c \
tsk.c \
truncate.c \
@@ -176,10 +197,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 +225,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 +250,69 @@ 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 \
+ 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 +334,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..6b8b452a5
--- /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 + { name = name;
chroot = chroot }
+
+let f t func arg + if verbose () then
+ eprintf "chroot: %s: running ‘%s’\n%!" t.chroot t.name;
+
+ let rfd, wfd = pipe () in
+
+ let pid = fork () in
+ if pid = 0 then (
+ (* Child. *)
+ close rfd;
+
+ chdir t.chroot;
+ chroot t.chroot;
+
+ let ret + try Either (func arg)
+ with exn -> Or exn in
+
+ try
+ let chan = out_channel_of_descr wfd in
+ output_value chan ret;
+ Pervasives.flush chan;
+ Exit._exit 0
+ with
+ exn ->
+ prerr_endline (Printexc.to_string exn);
+ Exit._exit 1
+ );
+
+ (* Parent. *)
+ close wfd;
+
+ let _, status = waitpid [] pid in
+ (match status with
+ | WEXITED 0 -> ()
+ | WEXITED i ->
+ close rfd;
+ failwithf "chroot ‘%s’ exited with non-zero error %d" t.name i
+ | WSIGNALED i ->
+ close rfd;
+ failwithf "chroot ‘%s’ killed by signal %d" t.name i
+ | WSTOPPED i ->
+ close rfd;
+ failwithf "chroot ‘%s’ stopped by signal %d" t.name i
+ );
+
+ let chan = in_channel_of_descr rfd in
+ let ret = input_value chan in
+ close_in chan;
+
+ match ret with
+ | Either ret -> ret
+ | Or exn -> raise exn
diff --git a/daemon/chroot.mli b/daemon/chroot.mli
new file mode 100644
index 000000000..eda3a785f
--- /dev/null
+++ b/daemon/chroot.mli
@@ -0,0 +1,35 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(** This is a generic module for running functions in a chroot.
+ The function runs in a forked subprocess too so that we can
+ restore the root afterwards.
+
+ It handles passing the parmeter, forking, running the
+ function and marshalling the result or any exceptions. *)
+
+type t
+
+val create : ?name:string -> string -> t
+(** Create a chroot handle. [?name] is an optional name used in
+ debugging and error messages. The string is the chroot
+ directory. *)
+
+val f : t -> ('a -> 'b) -> 'a -> 'b
+(** Run a function in the chroot, returning the result or re-raising
+ any exception thrown. *)
diff --git a/daemon/daemon-c.c b/daemon/daemon-c.c
new file mode 100644
index 000000000..da382bc35
--- /dev/null
+++ b/daemon/daemon-c.c
@@ -0,0 +1,35 @@
+/* guestfs-inspection
+ * Copyright (C) 2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA.
+ */
+
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <caml/mlvalues.h>
+
+#include "daemon.h"
+
+extern value guestfs_int_daemon_get_verbose_flag (value unitv);
+
+/* NB: This is a "noalloc" call. */
+value
+guestfs_int_daemon_get_verbose_flag (value unitv)
+{
+ return Val_bool (verbose);
+}
diff --git a/daemon/daemon.ml b/daemon/daemon.ml
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..1d35991b6 100644
--- a/daemon/guestfsd.c
+++ b/daemon/guestfsd.c
@@ -56,6 +56,10 @@
#include <augeas.h>
+#include <caml/callback.h>
+#include <caml/mlvalues.h>
+#include <caml/unixsupport.h>
+
#include "sockets.h"
#include "c-ctype.h"
#include "ignore-value.h"
@@ -348,6 +352,9 @@ main (int argc, char *argv[])
*/
udev_settle ();
+ /* Initialize the OCaml stubs. */
+ caml_startup (argv);
+
/* Send the magic length message which indicates that
* userspace is up inside the guest.
*/
@@ -1205,3 +1212,46 @@ cleanup_free_mountable (mountable_t *mountable)
free (mountable->volume);
}
}
+
+/* Convert an OCaml exception to a reply_with_error_errno call
+ * as best we can.
+ */
+extern void ocaml_exn_to_reply_with_error (const char *func, value exn);
+
+void
+ocaml_exn_to_reply_with_error (const char *func, value exn)
+{
+ 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);
+}
diff --git a/daemon/sysroot-c.c b/daemon/sysroot-c.c
new file mode 100644
index 000000000..ad31d36ee
--- /dev/null
+++ b/daemon/sysroot-c.c
@@ -0,0 +1,37 @@
+/* guestfs-inspection
+ * Copyright (C) 2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA.
+ */
+
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+#include "daemon.h"
+
+extern value guestfs_int_daemon_sysroot (value unitv);
+
+value
+guestfs_int_daemon_sysroot (value unitv)
+{
+ return caml_copy_string (sysroot);
+}
diff --git a/daemon/sysroot.ml b/daemon/sysroot.ml
new file mode 100644
index 000000000..ecf0d7362
--- /dev/null
+++ b/daemon/sysroot.ml
@@ -0,0 +1,19 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+external sysroot : unit -> string = "guestfs_int_daemon_sysroot"
diff --git a/daemon/sysroot.mli b/daemon/sysroot.mli
new file mode 100644
index 000000000..88f976476
--- /dev/null
+++ b/daemon/sysroot.mli
@@ -0,0 +1,22 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+val sysroot : unit -> string
+(** Return the current sysroot path where filesystems are mounted.
+ This comes from the daemon command line ([-r] option) or a built
+ in default. *)
diff --git a/daemon/utils.ml b/daemon/utils.ml
new file mode 100644
index 000000000..7630a5534
--- /dev/null
+++ b/daemon/utils.ml
@@ -0,0 +1,156 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Unix
+open Printf
+
+open Std_utils
+
+let prog_exists prog + try ignore (which prog); true
+ with Executable_not_found _ -> false
+
+let commandr prog args + if verbose () then
+ eprintf "command: %s %s\n%!"
+ prog (String.concat " " args);
+
+ let argv = Array.of_list (prog :: args) in
+
+ let stdout_file, stdout_chan = Filename.open_temp_file "cmd"
".out" in
+ let stderr_file, stderr_chan = Filename.open_temp_file "cmd"
".err" in
+ let stdout_fd = descr_of_out_channel stdout_chan in
+ let stderr_fd = descr_of_out_channel stderr_chan in
+ let stdin_fd = openfile "/dev/null" [O_RDONLY] 0 in
+
+ let pid = fork () in
+ if pid = 0 then (
+ (* Child process. *)
+ dup2 stdin_fd stdin;
+ close stdin_fd;
+ dup2 stdout_fd stdout;
+ close stdout_fd;
+ dup2 stderr_fd stderr;
+ close stderr_fd;
+
+ execvp prog argv
+ );
+
+ (* Parent process. *)
+ close stdin_fd;
+ close stdout_fd;
+ close stderr_fd;
+ let _, status = waitpid [] pid in
+ let r + match status with
+ | WEXITED i -> i
+ | WSIGNALED i ->
+ failwithf "external command ‘%s’ killed by signal %d" prog i
+ | WSTOPPED i ->
+ failwithf "external command ‘%s’ stopped by signal %d" prog i
in
+
+ if verbose () then
+ eprintf "command: %s returned %d\n" prog r;
+
+ let stdout = read_whole_file stdout_file in
+ let stderr = read_whole_file stderr_file in
+
+ if verbose () then (
+ if stdout <> "" then (
+ eprintf "command: %s: stdout:\n%s%!" prog stdout;
+ if not (String.is_suffix stdout "\n") then eprintf
"\n%!"
+ );
+ if stderr <> "" then (
+ eprintf "command: %s: stderr:\n%s%!" prog stderr;
+ if not (String.is_suffix stderr "\n") then eprintf
"\n%!"
+ )
+ );
+
+ (* Strip trailing \n from stderr but NOT from stdout. *)
+ let stderr + let n = String.length stderr in
+ if n > 0 && stderr.[n-1] = '\n' then
+ String.sub stderr 0 (n-1)
+ else
+ stderr in
+
+ (r, stdout, stderr)
+
+let command prog args + let r, stdout, stderr = commandr prog args in
+ if r <> 0 then
+ failwithf "%s exited with status %d: %s" prog r stderr;
+ stdout
+
+let udev_settle ?filename () + let args = ref [] in
+ if verbose () then
+ push_back args "--debug";
+ push_back args "settle";
+ (match filename with
+ | None -> ()
+ | Some filename ->
+ push_back args "-E";
+ push_back args filename
+ );
+ let args = !args in
+ let r, _, err = commandr "udevadm" args in
+ if r <> 0 then
+ eprintf "udevadm settle: %s\n" err
+
+let root_device = lazy ((stat "/").st_dev)
+
+let is_root_device_stat statbuf + statbuf.st_rdev = Lazy.force root_device
+
+let is_root_device device + udev_settle ~filename:device ();
+ try
+ let statbuf = stat device in
+ is_root_device_stat statbuf
+ with
+ Unix_error (err, func, arg) ->
+ eprintf "is_root_device: %s: %s: %s: %s\n"
+ device func arg (error_message err);
+ false
+
+let proc_unmangle_path path + let n = String.length path in
+ let b = Buffer.create n in
+ let rec loop i + if i < n-3 && path.[i] = '\\' then (
+ let to_int c = Char.code c - Char.code '0' in
+ let v + (to_int path.[i+1] lsl 6) lor
+ (to_int path.[i+2] lsl 3) lor
+ to_int path.[i+3] in
+ Buffer.add_char b (Char.chr v);
+ loop (i+4)
+ )
+ else if i < n then (
+ Buffer.add_char b path.[i];
+ loop (i+1)
+ )
+ else
+ Buffer.contents b
+ in
+ loop 0
+
+let is_small_file path + is_regular_file path &&
+ (stat path).st_size <= 2 * 1048 * 1024
diff --git a/daemon/utils.mli b/daemon/utils.mli
new file mode 100644
index 000000000..57f703c6c
--- /dev/null
+++ b/daemon/utils.mli
@@ -0,0 +1,65 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+val prog_exists : string -> bool
+(** Return true iff the program is found on [$PATH]. *)
+
+val udev_settle : ?filename:string -> unit -> unit
+(**
+ * LVM and other commands aren't synchronous, especially when udev is
+ * involved. eg. You can create or remove some device, but the
+ * [/dev] device node won't appear until some time later. This means
+ * that you get an error if you run one command followed by another.
+ *
+ * Use [udevadm settle] after certain commands, but don't be too
+ * fussed if it fails.
+ *
+ * The optional [?filename] passes the [udevadm settle -E filename]
+ * option, which means udevadm stops waiting as soon as the named
+ * file is created (or if it exists at the start).
+ *)
+
+val is_root_device : string -> bool
+(** Return true if this is the root (appliance) device. *)
+
+val is_root_device_stat : Unix.stats -> bool
+(** As for {!is_root_device} but operates on a statbuf instead of
+ a device name. *)
+
+val proc_unmangle_path : string -> string
+(** Reverse kernel path escaping done in fs/seq_file.c:mangle_path.
+ This is inconsistently used for /proc fields. *)
+
+val command : string -> string list -> string
+(** Run an external command without using the shell, and collect
+ stdout and stderr separately. Returns stdout if the command
+ runs successfully.
+
+ On failure of the command, this throws an exception containing
+ the stderr from the command. *)
+
+val commandr : string -> string list -> (int * string * string)
+(** Run an external command without using the shell, and collect
+ stdout and stderr separately.
+
+ Returns [status, stdout, stderr]. As with the C function in
+ [daemon/command.c], this strips the trailing [\n] from stderr,
+ but {b not} from stdout. *)
+
+val is_small_file : string -> bool
+(** Return true if the path is a small regular file. *)
diff --git a/docs/guestfs-hacking.pod b/docs/guestfs-hacking.pod
index 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/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..ac410b733 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -471,6 +471,193 @@ 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\"
+
+/* This is not declared in <daemon.h> because we don't want to
+ * include the OCaml headers (to get 'value') for the whole daemon.
+ */
+extern void ocaml_exn_to_reply_with_error (const char *func, value exn);
+
+";
+
+ List.iter (
+ fun ({ name = name; style = ret, args, optargs } as f) ->
+ let ocaml_function + match f.impl with
+ | OCaml f -> f
+ | C -> assert false in
+
+ pr "/* Wrapper for OCaml function ‘%s’. */\n" ocaml_function;
+
+ let args_do_function = args @ args_of_optargs optargs in
+ let args_do_function + List.filter (function
+ | String ((FileIn|FileOut), _) -> false | _ -> true)
+ args_do_function in
+ let style = ret, args_do_function, [] in
+ generate_prototype ~extern:false ~semicolon:false
+ ~single_line:false ~newline:false
+ ~in_daemon:true ~prefix:"do_"
+ name style;
+ pr "\n";
+
+ let add_unit_arg + let args = List.filter
+ (function
+ | String ((FileIn|FileOut), _) -> false | _ ->
true)
+ args in
+ args = [] in
+ let nr_args = List.length args_do_function in
+
+ pr "{\n";
+ pr " static value *cb = NULL;\n";
+ pr " CAMLparam0 ();\n";
+ pr " CAMLlocal2 (v, retv);\n";
+ pr " CAMLlocalN (args, %d);\n"
+ (nr_args + if add_unit_arg then 1 else 0);
+ pr "\n";
+ pr " if (cb == NULL)\n";
+ pr " cb = caml_named_value (\"%s\");\n"
ocaml_function;
+ pr "\n";
+
+ (* Construct the actual call, but note that we want to pass
+ * the optional arguments first in the list.
+ *)
+ let i = ref 0 in
+ List.iter (
+ fun optarg ->
+ let n = name_of_optargt optarg in
+ let uc_n = String.uppercase_ascii n in
+
+ (* optargs are all passed as [None|Some _] *)
+ pr " if ((optargs_bitmask & %s_%s_BITMASK) == 0)\n"
+ f.c_optarg_prefix uc_n;
+ pr " args[%d] = Val_int (0); /* None */\n" !i;
+ pr " else {\n";
+ pr " v = ";
+ (match optarg with
+ | OBool _ ->
+ pr "Val_bool (%s)" n;
+ | OInt _ -> assert false
+ | OInt64 _ -> assert false
+ | OString _ -> assert false
+ | OStringList _ -> assert false
+ );
+ pr ";\n";
+ pr " args[%d] = caml_alloc (1, 0);\n" !i;
+ pr " Store_field (args[%d], 0, v);\n" !i;
+ pr " }\n";
+ incr i
+ ) optargs;
+ List.iter (
+ fun arg ->
+ pr " args[%d] = " !i;
+ (match arg with
+ | Bool n -> pr "Val_bool (%s)" n
+ | Int n -> pr "Val_int (%s)" n
+ | Int64 n -> pr "caml_copy_int64 (%s)" n
+ | String (_, n) -> pr "caml_copy_string (%s)" n
+ | OptString _ -> assert false
+ | StringList _ -> assert false
+ | BufferIn _ -> assert false
+ | Pointer _ -> assert false
+ );
+ pr ";\n";
+ incr i
+ ) args;
+ assert (!i = nr_args);
+
+ (* If there are no non-optional arguments, we add a unit arg. *)
+ if add_unit_arg then
+ pr " args[%d] = Val_unit;\n" !i;
+
+ pr " retv = caml_callbackN_exn (*cb, %d, args);\n"
+ (nr_args + if add_unit_arg then 1 else 0);
+ pr "\n";
+ pr " if (Is_exception_result (retv)) {\n";
+ pr " retv = Extract_exception (retv);\n";
+ pr " ocaml_exn_to_reply_with_error (%S, retv);\n" name;
+ (match errcode_of_ret ret with
+ | `CannotReturnError ->
+ pr " CAMLreturn0;\n"
+ | `ErrorIsMinusOne ->
+ pr " CAMLreturnT (int, -1);\n"
+ | `ErrorIsNULL ->
+ pr " CAMLreturnT (void *, NULL);\n"
+ );
+ pr " }\n";
+ pr "\n";
+
+ (match ret with
+ | RErr -> assert false
+ | RInt _ -> assert false
+ | RInt64 _ -> assert false
+ | RBool _ -> assert false
+ | RConstString _ -> assert false
+ | RConstOptString _ -> assert false
+ | RString _ ->
+ pr " char *ret = strdup (String_val (retv));\n";
+ pr " if (ret == NULL) {\n";
+ pr " reply_with_perror (\"strdup\");\n";
+ pr " CAMLreturnT (char *, NULL);\n";
+ pr " }\n";
+ pr " CAMLreturnT (char *, ret); /* caller frees */\n"
+ | RStringList _ -> assert false
+ | RStruct _ -> assert false
+ | RStructList _ -> assert false
+ | RHashtable _ -> assert false
+ | RBufferOut _ -> assert false
+ );
+ pr "}\n";
+ pr "\n"
+ ) (actions |> impl_ocaml_functions |> sort)
+
let generate_daemon_dispatch () generate_header CStyle GPLv2plus;
diff --git a/generator/daemon.mli b/generator/daemon.mli
index ff008bf85..314a6da8f 100644
--- a/generator/daemon.mli
+++ b/generator/daemon.mli
@@ -19,6 +19,9 @@
val generate_daemon_actions_h : unit -> unit
val generate_daemon_stubs_h : unit -> unit
val generate_daemon_stubs : Types.action list -> unit -> unit
+val generate_daemon_caml_stubs : unit -> unit
+val generate_daemon_caml_callbacks_ml : unit -> unit
+val generate_daemon_caml_types_ml : unit -> unit
val generate_daemon_dispatch : unit -> unit
val generate_daemon_lvm_tokenization : unit -> unit
val generate_daemon_names : unit -> unit
diff --git a/generator/main.ml b/generator/main.ml
index c8890de6a..3a9d69b18 100644
--- a/generator/main.ml
+++ b/generator/main.ml
@@ -133,6 +133,12 @@ Run it from the top source directory using the command
Daemon.generate_daemon_stubs_h;
output_to_subset "daemon/stubs-%d.c"
Daemon.generate_daemon_stubs;
+ output_to "daemon/caml-stubs.c"
+ Daemon.generate_daemon_caml_stubs;
+ output_to "daemon/callbacks.ml"
+ Daemon.generate_daemon_caml_callbacks_ml;
+ output_to "daemon/types.ml"
+ Daemon.generate_daemon_caml_types_ml;
output_to "daemon/dispatch.c"
Daemon.generate_daemon_dispatch;
output_to "daemon/names.c"
diff --git a/generator/types.ml b/generator/types.ml
index 740bc7750..fb6c3bc06 100644
--- a/generator/types.ml
+++ b/generator/types.ml
@@ -379,11 +379,16 @@ type deprecated_by | Replaced_by of string (*
replaced by another function *)
| Deprecated_no_replacement (* deprecated with no replacement *)
+type impl + | C (* implemented in C by
"do_<name>" *)
+ | OCaml of string (* implemented in OCaml by named function *)
+
(* Type of an action as declared in Actions module. *)
type action = {
name : string; (* name, not including "guestfs_"
*)
added : version; (* which version was the API first added *)
style : style; (* args and return value *)
+ impl : impl; (* implementation language (C or OCaml) *)
proc_nr : int option; (* proc number, None for non-daemon *)
tests : c_api_tests; (* C API tests *)
test_excuse : string; (* if there's no tests ... *)
@@ -439,7 +444,7 @@ type action = {
*)
let defaults = { name = "";
added = (-1,-1,-1);
- style = RErr, [], []; proc_nr = None;
+ style = RErr, [], []; impl = C; proc_nr = None;
tests = []; test_excuse = "";
shortdesc = ""; longdesc = "";
protocol_limit_warning = false; fish_alias = [];
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 03/27] 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 | 60 +++++++++++++++++++++++++++++++++++
daemon/file.mli | 19 +++++++++++
generator/actions_core.ml | 1 +
5 files changed, 82 insertions(+), 80 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 40b770762..6fb1c5384 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -256,6 +256,7 @@ guestfsd_CFLAGS = \
SOURCES_MLI = \
chroot.mli \
sysroot.mli \
+ file.mli \
utils.mli
SOURCES_ML = \
@@ -263,6 +264,7 @@ SOURCES_ML = \
utils.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..557de764b
--- /dev/null
+++ b/daemon/file.ml
@@ -0,0 +1,60 @@
+(* 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 sysroot = Sysroot.sysroot () in
+ let chroot = Chroot.create sysroot ~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 // 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-14 13:39 UTC
[Libguestfs] [PATCH 04/27] daemon: Reimplement ‘vfs_type’ API in OCaml.
This also implements support for String (Mountable, _)
parameters.
---
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 +
generator/daemon.ml | 38 ++++++++++++++++++++++++++++++++++++--
8 files changed, 177 insertions(+), 8 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 6fb1c5384..62a009dc5 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -254,16 +254,20 @@ 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 = \
types.ml \
utils.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..3345f826e
--- /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.trimr out
+
+ | 2 -> (* means tag not found, we return
"" *)
+ ""
+
+ | _ ->
+ failwithf "blkid: %s: %s" 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"), []
diff --git a/generator/daemon.ml b/generator/daemon.ml
index ac410b733..121634806 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -524,6 +524,35 @@ let generate_daemon_caml_stubs () */
extern void ocaml_exn_to_reply_with_error (const char *func, value exn);
+/* Implement String (Mountable, _) parameter. */
+static value
+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);
+}
+
";
List.iter (
@@ -602,7 +631,11 @@ extern void ocaml_exn_to_reply_with_error (const char
*func, value exn);
| Bool n -> pr "Val_bool (%s)" n
| Int n -> pr "Val_int (%s)" n
| Int64 n -> pr "caml_copy_int64 (%s)" n
- | String (_, n) -> pr "caml_copy_string (%s)" n
+ | String ((PlainString|Device|Dev_or_Path), n) ->
+ pr "caml_copy_string (%s)" n
+ | String (Mountable, n) ->
+ pr "copy_mountable (%s)" n
+ | String _ -> assert false
| OptString _ -> assert false
| StringList _ -> assert false
| BufferIn _ -> assert false
@@ -641,13 +674,14 @@ extern void ocaml_exn_to_reply_with_error (const char
*func, value exn);
| RBool _ -> assert false
| RConstString _ -> assert false
| RConstOptString _ -> assert false
- | RString _ ->
+ | RString (RPlainString, _) ->
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 _ -> assert false
| RStringList _ -> assert false
| RStruct _ -> assert false
| RStructList _ -> assert false
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 05/27] 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 | 109 ++++++++++++++++++++
daemon/devsparts.mli | 25 +++++
daemon/guestfsd.c | 75 --------------
daemon/utils.ml | 84 +++++++++++++++
daemon/utils.mli | 15 +++
generator/actions_core.ml | 5 +
generator/daemon.ml | 32 +++++-
10 files changed, 268 insertions(+), 339 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 62a009dc5..5bb47d08b 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -257,6 +257,7 @@ SOURCES_MLI = \
blkid.mli \
chroot.mli \
sysroot.mli \
+ devsparts.mli \
file.mli \
mountable.mli \
utils.mli
@@ -268,6 +269,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..e97ff1267
--- /dev/null
+++ b/daemon/devsparts.ml
@@ -0,0 +1,109 @@
+(* 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 close (openfile ("/dev/" ^ dev) [O_RDONLY; O_CLOEXEC] 0);
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 (fun dev ->
"/dev/" ^ 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 (fun part -> "/dev/" ^ part) 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 1d35991b6..dbc8fef45 100644
--- a/daemon/guestfsd.c
+++ b/daemon/guestfsd.c
@@ -630,81 +630,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 7630a5534..48f6b9c5c 100644
--- a/daemon/utils.ml
+++ b/daemon/utils.ml
@@ -129,6 +129,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 57f703c6c..a1f956be3 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"]]), [];
diff --git a/generator/daemon.ml b/generator/daemon.ml
index 121634806..3ffe91537 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -553,6 +553,26 @@ copy_mountable (const mountable_t *mountable)
CAMLreturn (r);
}
+/* Implement RStringList. */
+static char **
+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 */
+}
+
";
List.iter (
@@ -669,12 +689,14 @@ copy_mountable (const mountable_t *mountable)
(match ret with
| RErr -> assert false
- | RInt _ -> assert false
+ | RInt _ ->
+ pr " CAMLreturnT (int, Int_val (retv));\n"
| RInt64 _ -> assert false
- | RBool _ -> assert false
+ | RBool _ ->
+ pr " CAMLreturnT (int, Bool_val (retv));\n"
| RConstString _ -> assert false
| RConstOptString _ -> assert false
- | RString (RPlainString, _) ->
+ | RString ((RPlainString|RDevice), _) ->
pr " char *ret = strdup (String_val (retv));\n";
pr " if (ret == NULL) {\n";
pr " reply_with_perror (\"strdup\");\n";
@@ -682,7 +704,9 @@ copy_mountable (const mountable_t *mountable)
pr " }\n";
pr " CAMLreturnT (char *, ret); /* caller frees */\n"
| RString _ -> assert false
- | RStringList _ -> assert false
+ | RStringList _ ->
+ pr " char **ret = return_string_list (retv);\n";
+ pr " CAMLreturnT (char **, ret); /* caller frees */\n"
| RStruct _ -> assert false
| RStructList _ -> assert false
| RHashtable _ -> assert false
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 06/27] 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 815431b7b..0fb2d258b 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 5bb47d08b..3b49ae3bb 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -56,6 +56,7 @@ BUILT_SOURCES = \
EXTRA_DIST = \
$(generator_built) \
$(SOURCES_MLI) $(SOURCES_ML) \
+ daemon_utils_tests.ml \
guestfsd.pod
if INSTALL_DAEMON
@@ -280,7 +281,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)
@@ -307,6 +309,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 a3ac13b7c..6149bba43 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -94,6 +94,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-14 13:39 UTC
[Libguestfs] [PATCH 07/27] 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 | 44 ++++++++++++++++++++++++++++++++++++++++++++
daemon/is.mli | 21 +++++++++++++++++++++
generator/actions_core.ml | 3 +++
generator/daemon.ml | 7 ++++---
6 files changed, 74 insertions(+), 44 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 3b49ae3bb..32c8d93c8 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -260,6 +260,7 @@ SOURCES_MLI = \
sysroot.mli \
devsparts.mli \
file.mli \
+ is.mli \
mountable.mli \
utils.mli
@@ -272,6 +273,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..b99215737
--- /dev/null
+++ b/daemon/is.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 Printf
+open Unix
+
+let rec is_file ?(followsymlinks = false) path + let sysroot = Sysroot.sysroot
() in
+ let chroot = Chroot.create sysroot ~name:(sprintf "is_file: %s"
path) in
+ Chroot.f chroot get_kind (path, followsymlinks) = Some S_REG
+
+and is_dir ?(followsymlinks = false) path + let sysroot = Sysroot.sysroot ()
in
+ let chroot = Chroot.create sysroot ~name:(sprintf "is_dir: %s"
path) in
+ Chroot.f chroot get_kind (path, followsymlinks) = Some S_DIR
+
+and is_symlink path + let sysroot = Sysroot.sysroot () in
+ let chroot = Chroot.create sysroot ~name:(sprintf "is_symlink: %s"
path) in
+ Chroot.f chroot get_kind (path, false) = Some S_LNK
+
+and get_kind (path, followsymlinks) + 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 *)
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"]]), [];
diff --git a/generator/daemon.ml b/generator/daemon.ml
index 3ffe91537..ef6086bfe 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -577,6 +577,7 @@ return_string_list (value retv)
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
@@ -625,8 +626,8 @@ return_string_list (value retv)
let uc_n = String.uppercase_ascii n in
(* optargs are all passed as [None|Some _] *)
- pr " if ((optargs_bitmask & %s_%s_BITMASK) == 0)\n"
- f.c_optarg_prefix uc_n;
+ pr " 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 = ";
@@ -651,7 +652,7 @@ return_string_list (value retv)
| 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|Dev_or_Path), n) ->
+ | String ((PlainString|Device|Pathname|Dev_or_Path), n) ->
pr "caml_copy_string (%s)" n
| String (Mountable, n) ->
pr "copy_mountable (%s)" n
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 08/27] daemon: Reimplement ‘readlink’ API in OCaml.
---
daemon/Makefile.am | 2 ++
daemon/link.c | 16 ----------------
daemon/link.ml | 25 +++++++++++++++++++++++++
daemon/link.mli | 19 +++++++++++++++++++
generator/actions_core.ml | 1 +
5 files changed, 47 insertions(+), 16 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 32c8d93c8..fab82ebbe 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -261,6 +261,7 @@ SOURCES_MLI = \
devsparts.mli \
file.mli \
is.mli \
+ link.mli \
mountable.mli \
utils.mli
@@ -274,6 +275,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..ba53fd6b5
--- /dev/null
+++ b/daemon/link.ml
@@ -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.
+ *)
+
+open Printf
+open Unix
+
+let readlink path + let sysroot = Sysroot.sysroot () in
+ let chroot = Chroot.create sysroot ~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-14 13:39 UTC
[Libguestfs] [PATCH 09/27] 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 ++
generator/daemon.ml | 3 +-
8 files changed, 135 insertions(+), 106 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index fab82ebbe..5fd0d77c6 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -262,6 +262,7 @@ SOURCES_MLI = \
file.mli \
is.mli \
link.mli \
+ mount.mli \
mountable.mli \
utils.mli
@@ -276,6 +277,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..4bb74fb82
--- /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 ()
// 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
diff --git a/generator/daemon.ml b/generator/daemon.ml
index ef6086bfe..fd01e5d8a 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -689,7 +689,8 @@ return_string_list (value retv)
pr "\n";
(match ret with
- | RErr -> assert false
+ | RErr ->
+ pr " CAMLreturnT (int, 0);\n"
| RInt _ ->
pr " CAMLreturnT (int, Int_val (retv));\n"
| RInt64 _ -> assert false
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 10/27] 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 5fd0d77c6..4ee62e564 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -264,6 +264,7 @@ SOURCES_MLI = \
link.mli \
mount.mli \
mountable.mli \
+ parted.mli \
utils.mli
SOURCES_ML = \
@@ -278,6 +279,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-14 13:39 UTC
[Libguestfs] [PATCH 11/27] daemon: Reimplement ‘case_sensitive_path’ API in OCaml.
---
daemon/Makefile.am | 2 +
daemon/realpath.c | 187 ----------------------------------------------
daemon/realpath.ml | 83 ++++++++++++++++++++
daemon/realpath.mli | 19 +++++
generator/actions_core.ml | 1 +
5 files changed, 105 insertions(+), 187 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 4ee62e564..9baf13422 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -265,6 +265,7 @@ SOURCES_MLI = \
mount.mli \
mountable.mli \
parted.mli \
+ realpath.mli \
utils.mli
SOURCES_ML = \
@@ -280,6 +281,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..cffe86322
--- /dev/null
+++ b/daemon/realpath.ml
@@ -0,0 +1,83 @@
+(* 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 sysroot = Sysroot.sysroot () in
+ let chroot = Chroot.create sysroot
+ ~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-14 13:39 UTC
[Libguestfs] [PATCH 12/27] 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 | 137 +++++++++++++++++
daemon/filearch.mli | 19 +++
docs/C_SOURCE_FILES | 4 +-
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 9baf13422..7c50e1346 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -260,6 +260,7 @@ SOURCES_MLI = \
sysroot.mli \
devsparts.mli \
file.mli \
+ filearch.mli \
is.mli \
link.mli \
mount.mli \
@@ -277,6 +278,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..987006a4d
--- /dev/null
+++ b/daemon/filearch.ml
@@ -0,0 +1,137 @@
+(* 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
+
+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. Caller must free the result.
+ *)
+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 sysroot = Sysroot.sysroot () in
+
+ 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 = sprintf "/tmp/%s" (String.random8 ()) in
+ mkdir tmpdir 0o700;
+
+ (* 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 // 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 6149bba43..2dbd5a14b 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,7 @@ daemon/compress.c
daemon/copy.c
daemon/cpio.c
daemon/cpmv.c
+daemon/daemon-c.c
daemon/daemon.h
daemon/dd.c
daemon/debug-bmap.c
@@ -173,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
@@ -296,7 +299,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 bca4bf90e..eebc203fd 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-14 13:39 UTC
[Libguestfs] [PATCH 13/27] daemon: Reimplement ‘list_ldm_(volumes|partitions)’ APIs in OCaml.
---
daemon/Makefile.am | 2 ++
daemon/ldm.c | 82 -----------------------------------------------
daemon/ldm.ml | 52 ++++++++++++++++++++++++++++++
daemon/ldm.mli | 20 ++++++++++++
generator/actions_core.ml | 2 ++
5 files changed, 76 insertions(+), 82 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 7c50e1346..22a3036f8 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -262,6 +262,7 @@ SOURCES_MLI = \
file.mli \
filearch.mli \
is.mli \
+ ldm.mli \
link.mli \
mount.mli \
mountable.mli \
@@ -280,6 +281,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..dc7b36f9c
--- /dev/null
+++ b/daemon/ldm.ml
@@ -0,0 +1,52 @@
+(* 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_*. XXX We
+ * could tighten this up in future if ldmtool had a way to read these
+ * names back after they have been created.
+ *)
+let list_ldm_volumes () + (* 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
"ldm_vol_") dir in
+ let dir = List.map ((^) "/dev/mapper/") dir in
+ List.sort compare dir
+ )
+
+(* Same as above but /dev/mapper/ldm_part_*. *)
+let list_ldm_partitions () + (* 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
"ldm_part_") 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-14 13:39 UTC
[Libguestfs] [PATCH 14/27] daemon: Reimplement ‘lvs’ API in OCaml.
---
daemon/Makefile.am | 2 +
daemon/lvm.c | 151 ----------------------------------------------
daemon/lvm.ml | 92 ++++++++++++++++++++++++++++
daemon/lvm.mli | 19 ++++++
generator/actions_core.ml | 1 +
5 files changed, 114 insertions(+), 151 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 22a3036f8..e9c71ba3c 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -264,6 +264,7 @@ SOURCES_MLI = \
is.mli \
ldm.mli \
link.mli \
+ lvm.mli \
mount.mli \
mountable.mli \
parted.mli \
@@ -283,6 +284,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..55421b628
--- /dev/null
+++ b/daemon/lvm.ml
@@ -0,0 +1,92 @@
+(* 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
+
+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 = 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-14 13:39 UTC
[Libguestfs] [PATCH 15/27] 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 e9c71ba3c..62ce49498 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -265,6 +265,7 @@ SOURCES_MLI = \
ldm.mli \
link.mli \
lvm.mli \
+ md.mli \
mount.mli \
mountable.mli \
parted.mli \
@@ -285,6 +286,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-14 13:39 UTC
[Libguestfs] [PATCH 16/27] daemon: Generate OCaml wrappers for optgroup_*_available functions.
It is sometimes useful to be able to call these from OCaml code.
---
generator/daemon.ml | 23 ++++++++++++++++++++++-
1 file changed, 22 insertions(+), 1 deletion(-)
diff --git a/generator/daemon.ml b/generator/daemon.ml
index fd01e5d8a..1d7461f8c 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -976,6 +976,10 @@ let generate_daemon_optgroups_c () generate_header
CStyle GPLv2plus;
pr "#include <config.h>\n";
+ pr "#include <stdio.h>\n";
+ pr "#include <stdlib.h>\n";
+ pr "\n";
+ pr "#include <caml/mlvalues.h>\n";
pr "\n";
pr "#include \"daemon.h\"\n";
pr "#include \"optgroups.h\"\n";
@@ -999,7 +1003,24 @@ 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 ->
+ if not (List.mem group optgroups_retired) then (
+ 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_all
let generate_daemon_optgroups_h () generate_header CStyle GPLv2plus;
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 17/27] daemon: Enable RStruct, RStructList for OCaml-implemented APIs.
---
.gitignore | 1 +
daemon/Makefile.am | 1 +
generator/OCaml.ml | 8 ++++
generator/OCaml.mli | 1 +
generator/daemon.ml | 116 +++++++++++++++++++++++++++++++++++++++++++++++++++-
generator/main.ml | 2 +
6 files changed, 127 insertions(+), 2 deletions(-)
diff --git a/.gitignore b/.gitignore
index 0fb2d258b..c553141e9 100644
--- a/.gitignore
+++ b/.gitignore
@@ -181,6 +181,7 @@ Makefile.in
/daemon/stamp-guestfsd.pod
/daemon/structs-cleanups.c
/daemon/structs-cleanups.h
+/daemon/structs.ml
/daemon/stubs-?.c
/daemon/stubs.h
/daemon/types.ml
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 62ce49498..b49b7d907 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -275,6 +275,7 @@ SOURCES_MLI = \
SOURCES_ML = \
types.ml \
utils.ml \
+ structs.ml \
sysroot.ml \
mountable.ml \
chroot.ml \
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/daemon.ml b/generator/daemon.ml
index 1d7461f8c..8cac5ccb1 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -575,6 +575,110 @@ return_string_list (value retv)
";
+ (* 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
@@ -709,8 +813,16 @@ return_string_list (value retv)
| RStringList _ ->
pr " char **ret = return_string_list (retv);\n";
pr " CAMLreturnT (char **, ret); /* caller frees */\n"
- | RStruct _ -> assert false
- | RStructList _ -> assert false
+ | 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 _ -> assert false
| RBufferOut _ -> assert false
);
diff --git a/generator/main.ml b/generator/main.ml
index 3a9d69b18..c61326b61 100644
--- a/generator/main.ml
+++ b/generator/main.ml
@@ -191,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;
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 18/27] daemon: Reimplement ‘btrfs_subvolume_list’ and ‘btrfs_subvolume_get_default’ in OCaml.
---
daemon/Makefile.am | 2 +
daemon/btrfs.c | 175 ----------------------------------------------
daemon/btrfs.ml | 127 +++++++++++++++++++++++++++++++++
daemon/btrfs.mli | 26 +++++++
generator/actions_core.ml | 2 +
generator/daemon.ml | 5 +-
6 files changed, 160 insertions(+), 177 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index b49b7d907..87e608688 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -256,6 +256,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 \
@@ -280,6 +281,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..554212ccf
--- /dev/null
+++ b/daemon/btrfs.ml
@@ -0,0 +1,127 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Printf
+open Scanf
+open Unix
+
+open Std_utils
+
+open 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 with_mounted mountable f + let tmpdir = sprintf "/tmp/%s"
(String.random8 ()) 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
+
+ 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 () // mountable.m_device)
+
+ | MountableDevice ->
+ protect ~finally ~f:(
+ fun () ->
+ mkdir tmpdir 0o700;
+ ignore (command "mount" [mountable.m_device; tmpdir]);
+ f tmpdir
+ )
+
+ | MountableBtrfsVol subvol ->
+ protect ~finally ~f:(
+ fun () ->
+ mkdir tmpdir 0o700;
+ ignore (command "mount" ["-o"; "subvol="
^ subvol (* XXX quoting? *);
+ mountable.m_device; 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
+
+ (* 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.
+ *)
+ filter_map (
+ fun line ->
+ if line = "" then None
+ else 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
+
+ Some {
+ 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 (
diff --git a/generator/daemon.ml b/generator/daemon.ml
index 8cac5ccb1..83994e9d3 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -758,7 +758,7 @@ return_string_list (value retv)
| Int64 n -> pr "caml_copy_int64 (%s)" n
| String ((PlainString|Device|Pathname|Dev_or_Path), n) ->
pr "caml_copy_string (%s)" n
- | String (Mountable, n) ->
+ | String ((Mountable|Mountable_or_Path), n) ->
pr "copy_mountable (%s)" n
| String _ -> assert false
| OptString _ -> assert false
@@ -797,7 +797,8 @@ return_string_list (value retv)
pr " CAMLreturnT (int, 0);\n"
| RInt _ ->
pr " CAMLreturnT (int, Int_val (retv));\n"
- | RInt64 _ -> assert false
+ | RInt64 _ ->
+ pr " CAMLreturnT (int, Int64_val (retv));\n"
| RBool _ ->
pr " CAMLreturnT (int, Bool_val (retv));\n"
| RConstString _ -> assert false
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 19/27] 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 | 156 +++++++++++++++++++++++++++++
daemon/listfs.mli | 19 ++++
daemon/lvm.ml | 3 +
daemon/lvm.mli | 2 +
docs/C_SOURCE_FILES | 1 -
generator/actions_core.ml | 75 +++++++-------
generator/daemon.ml | 59 ++++++++++-
generator/proc_nr.ml | 1 +
lib/MAX_PROC_NR | 2 +-
lib/Makefile.am | 1 -
lib/listfs.c | 246 ----------------------------------------------
14 files changed, 285 insertions(+), 287 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 87e608688..d239f38ef 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -265,6 +265,7 @@ SOURCES_MLI = \
is.mli \
ldm.mli \
link.mli \
+ listfs.mli \
lvm.mli \
md.mli \
mount.mli \
@@ -292,6 +293,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 dc7b36f9c..19cd03e83 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_*. XXX We
* could tighten this up in future if ldmtool had a way to read these
* names back after they have been created.
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..df5404f81
--- /dev/null
+++ b/daemon/listfs.ml
@@ -0,0 +1,156 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2017 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open 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 = List.fold_left (
+ fun devices part ->
+ let d = Devsparts.part_to_dev part in
+ List.filter ((<>) d) devices
+ ) devices partitions 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 55421b628..14f0a8578 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"
+
let lvs_has_S_opt = lazy (
let out = command "lvm" ["lvs"; "--help"] in
String.find out "-S" >= 0
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 2dbd5a14b..74588d488 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -324,7 +324,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/daemon.ml b/generator/daemon.ml
index 83994e9d3..66b625388 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -573,6 +573,58 @@ return_string_list (value retv)
return take_stringsbuf (&ret); /* caller frees */
}
+/* Implement RString (RMountable, _). */
+static char *
+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 (RMountable, RPlainString, _). */
+static char **
+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 = 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 */
+}
+
";
(* Implement code for returning structs and struct lists. *)
@@ -810,7 +862,9 @@ return_string_list (value retv)
pr " CAMLreturnT (char *, NULL);\n";
pr " }\n";
pr " CAMLreturnT (char *, ret); /* caller frees */\n"
- | RString _ -> assert false
+ | RString (RMountable, _) ->
+ pr " char *ret = return_string_mountable (retv);\n";
+ pr " CAMLreturnT (char *, ret); /* caller frees */\n"
| RStringList _ ->
pr " char **ret = return_string_list (retv);\n";
pr " CAMLreturnT (char **, ret); /* caller frees */\n"
@@ -824,6 +878,9 @@ return_string_list (value retv)
pr " return_%s_list (retv);\n" typ;
pr " /* caller frees */\n";
pr " CAMLreturnT (guestfs_int_%s_list *, ret);\n" typ
+ | RHashtable (RMountable, RPlainString, _) ->
+ pr " char **ret = return_hashtable_mountable_string
(retv);\n";
+ pr " CAMLreturnT (char **, ret); /* caller frees */\n"
| RHashtable _ -> assert false
| RBufferOut _ -> assert false
);
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-14 13:39 UTC
[Libguestfs] [PATCH 20/27] daemon: Reimplement ‘part_list’ API in OCaml.
---
daemon/parted.c | 56 -----------------------------------------------
daemon/parted.ml | 51 ++++++++++++++++++++++++++++++++++++++++++
daemon/parted.mli | 8 +++++++
generator/actions_core.ml | 1 +
4 files changed, 60 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..37e1b42be 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,52 @@ let part_get_mbr_id device partnum
(* It's printed in hex, possibly with a leading space. *)
sscanf out " %x" identity
+
+let print_partition_table ~add_m_option device + udev_settle ();
+
+ let args = ref [] in
+ if add_m_option then 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 ~add_m_option:true
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-14 13:39 UTC
[Libguestfs] [PATCH 21/27] 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 d239f38ef..a864b6996 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -108,7 +108,6 @@ guestfsd_SOURCES = \
ext2.c \
fallocate.c \
file.c \
- findfs.c \
fill.c \
find.c \
format.c \
@@ -262,6 +261,7 @@ SOURCES_MLI = \
devsparts.mli \
file.mli \
filearch.mli \
+ findfs.mli \
is.mli \
ldm.mli \
link.mli \
@@ -290,6 +290,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 14f0a8578..5dd01d6b2 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
@@ -93,3 +94,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 74588d488..8bdb40da9 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -103,7 +103,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-14 13:39 UTC
[Libguestfs] [PATCH 22/27] 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 e97ff1267..273612516 100644
--- a/daemon/devsparts.ml
+++ b/daemon/devsparts.ml
@@ -85,6 +85,8 @@ and add_partitions dev let parts = List.filter (fun part
-> String.is_prefix part dev) parts in
List.map (fun part -> "/dev/" ^ part) 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-14 13:39 UTC
[Libguestfs] [PATCH 23/27] daemon: Reimplement ‘md_detail’ API in OCaml.
---
daemon/md.c | 66 -----------------------------------------------
daemon/md.ml | 37 ++++++++++++++++++++++++++
daemon/md.mli | 1 +
generator/actions_core.ml | 1 +
generator/daemon.ml | 27 +++++++++++++++++++
5 files changed, 66 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..ba045b5f7 100644
--- a/daemon/md.ml
+++ b/daemon/md.ml
@@ -46,3 +46,40 @@ 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
+
+ (* 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
+ *)
+ filter_map (
+ fun line ->
+ (* Skip blank lines (shouldn't happen). *)
+ if line = "" then None
+ else (
+ (* 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. *)
+ Some (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 = "\
diff --git a/generator/daemon.ml b/generator/daemon.ml
index 66b625388..f20c87bea 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -597,6 +597,30 @@ return_string_mountable (value retv)
}
}
+/* Implement RHashtable (RPlainString, RPlainString, _). */
+static char **
+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, _). */
static char **
return_hashtable_mountable_string (value retv)
@@ -878,6 +902,9 @@ return_hashtable_mountable_string (value retv)
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 = return_hashtable_string_string
(retv);\n";
+ pr " CAMLreturnT (char **, ret); /* caller frees */\n"
| RHashtable (RMountable, RPlainString, _) ->
pr " char **ret = return_hashtable_mountable_string
(retv);\n";
pr " CAMLreturnT (char **, ret); /* caller frees */\n"
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 24/27] daemon: Reimplement ‘realpath’ API in OCaml.
---
daemon/Makefile.am | 1 -
daemon/realpath.c | 50 -----------------------------------------------
daemon/realpath.ml | 5 +++++
daemon/realpath.mli | 1 +
docs/C_SOURCE_FILES | 1 -
generator/actions_core.ml | 1 +
6 files changed, 7 insertions(+), 52 deletions(-)
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index a864b6996..8921f6239 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -153,7 +153,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 cffe86322..4b4971dd7 100644
--- a/daemon/realpath.ml
+++ b/daemon/realpath.ml
@@ -20,6 +20,11 @@ open Printf
open Std_utils
+let realpath path + let chroot = Chroot.create ~name:(sprintf "realpath:
%s" path)
+ (Sysroot.sysroot ()) 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 8bdb40da9..3601c3d5d 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -146,7 +146,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-14 13:39 UTC
[Libguestfs] [PATCH 25/27] daemon: Implement command flag CommandFlagFoldStdoutOnStderr.
Used to handle broken commands like parted, sgdisk which print errors
on stdout.
---
daemon/utils.ml | 19 ++++++++++++++-----
daemon/utils.mli | 11 +++++++++--
2 files changed, 23 insertions(+), 7 deletions(-)
diff --git a/daemon/utils.ml b/daemon/utils.ml
index 48f6b9c5c..808e575fd 100644
--- a/daemon/utils.ml
+++ b/daemon/utils.ml
@@ -25,9 +25,15 @@ let prog_exists prog try ignore (which prog); true
with Executable_not_found _ -> false
-let commandr prog args +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%!"
+ eprintf "command:%s %s %s\n%!"
+ (if fold_stdout_on_stderr then " fold-stdout-on-stderr"
else "")
prog (String.concat " " args);
let argv = Array.of_list (prog :: args) in
@@ -43,7 +49,10 @@ let commandr prog args (* Child process. *)
dup2 stdin_fd stdin;
close stdin_fd;
- dup2 stdout_fd stdout;
+ 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;
@@ -91,8 +100,8 @@ let commandr prog args
(r, stdout, stderr)
-let command prog args - let r, stdout, stderr = commandr prog args in
+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
diff --git a/daemon/utils.mli b/daemon/utils.mli
index a1f956be3..d3c8bdf4d 100644
--- a/daemon/utils.mli
+++ b/daemon/utils.mli
@@ -60,7 +60,14 @@ val proc_unmangle_path : string -> string
(** Reverse kernel path escaping done in fs/seq_file.c:mangle_path.
This is inconsistently used for /proc fields. *)
-val command : string -> string list -> string
+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.
@@ -68,7 +75,7 @@ val command : string -> string list -> string
On failure of the command, this throws an exception containing
the stderr from the command. *)
-val commandr : string -> string list -> (int * string * string)
+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.
--
2.13.2
Richard W.M. Jones
2017-Jul-14 13:39 UTC
[Libguestfs] [PATCH 26/27] 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 37e1b42be..7c1e577dd 100644
--- a/daemon/parted.ml
+++ b/daemon/parted.ml
@@ -81,18 +81,18 @@ let print_partition_table ~add_m_option 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 ~add_m_option:true
device in
+ let _, lines = print_partition_table ~add_m_option:true device in
List.map (
fun line ->
@@ -104,3 +104,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
~add_m_option:true 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-14 13:39 UTC
[Libguestfs] [PATCH 27/27] 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 273612516..4d273f59e 100644
--- a/daemon/devsparts.ml
+++ b/daemon/devsparts.ml
@@ -109,3 +109,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-18 15:54 UTC
Re: [Libguestfs] [PATCH 01/27] build: Make OCaml compiler required for all builds.
On Friday, 14 July 2017 15:39:09 CEST Richard W.M. Jones wrote:> Previously the OCaml compiler was only required if building from git > but was at least theoretically optional if building from tarballs > (although this was never tested). Since we want to write parts of the > daemon in OCaml, this makes OCaml required for all builds. > > Note that the ‘--disable-ocaml’ option remains, but it now only > disables OCaml bindings and OCaml virt tools. Using this option does > not disable the OCaml compiler requirement. > > Also note that ‘HAVE_OCAML’ changes meaning slightly, so it now means > "build OCaml bindings and tools" (analogous to ‘HAVE_PERL’ and > others). The generator, daemon [in a future commit], and some utility > libraries needed by the generator or daemon do not test for this macro > because we can assume OCaml compiler availability. > ---This LGTM, although i'd have taken one step further and always build all the OCaml stuff regardless (so removing --disable-ocaml, or making it show a "this is void now" message). -- Pino Toscano
Pino Toscano
2017-Jul-18 16:13 UTC
Re: [Libguestfs] [PATCH 01/27] build: Make OCaml compiler required for all builds.
On Friday, 14 July 2017 15:39:09 CEST Richard W.M. Jones wrote:> +dnl Check for <caml/unixsupport.h> header. > +old_CPPFLAGS="$CPPFLAGS" > +CPPFLAGS="$CPPFLAGS -I`$OCAMLC -where`" > +AC_CHECK_HEADERS([caml/unixsupport.h],[],[],[#include <caml/mlvalues.h>]) > +CPPFLAGS="$old_CPPFLAGS"The minimum version of OCaml is 3.11, and it seems to have this header already; since at least patch #2 uses it unconditionally, I'd add a patch after this to drop its search, and all the HAVE_CAML_UNIXSUPPORT_H blocks all around. -- Pino Toscano
Pino Toscano
2017-Jul-19 10:57 UTC
Re: [Libguestfs] [PATCH 06/27] daemon: Add unit tests of the ‘Utils’ module.
Would it be possible to use oUnit too? -- Pino Toscano
Pino Toscano
2017-Jul-19 13:13 UTC
Re: [Libguestfs] [PATCH 02/27] daemon: Allow parts of the daemon and APIs to be written in OCaml.
On Friday, 14 July 2017 15:39:10 CEST Richard W.M. Jones wrote:> .gitignore | 6 +- > Makefile.am | 2 +- > common/mlutils/Makefile.am | 4 - > daemon/Makefile.am | 103 +++++++++++++++++++++++-- > daemon/chroot.ml | 85 +++++++++++++++++++++ > daemon/chroot.mli | 35 +++++++++ > daemon/daemon-c.c | 35 +++++++++ > daemon/daemon.ml | 39 ++++++++++ > daemon/guestfsd.c | 50 ++++++++++++ > daemon/sysroot-c.c | 37 +++++++++ > daemon/sysroot.ml | 19 +++++ > daemon/sysroot.mli | 22 ++++++ > daemon/utils.ml | 156 +++++++++++++++++++++++++++++++++++++ > daemon/utils.mli | 65 ++++++++++++++++TBH I'd just have a single "Daemon" module for the OCaml helpers for the daemon, instead of different modules, wirh a single -c.c file for all the C implementations. The Sysroot submodule could be implemented like the various submodules in Unix_utils.> diff --git a/daemon/Makefile.am b/daemon/Makefile.am > index eedf09d52..40b770762 100644 > --- a/daemon/Makefile.am > +++ b/daemon/Makefile.am > @@ -19,6 +19,7 @@ include $(top_srcdir)/subdir-rules.mk > > generator_built = \ > actions.h \ > + caml-stubs.c \ > dispatch.c \ > names.c \ > lvm-tokenization.c \ > @@ -31,13 +32,30 @@ generator_built = \ > stubs-4.c \ > stubs-5.c \ > stubs-6.c \ > - stubs.h > + stubs.h \ > + callbacks.ml \ > + types.ml > > BUILT_SOURCES = \ > - $(generator_built) > + actions.h \ > + caml-stubs.c \ > + dispatch.c \ > + names.c \ > + lvm-tokenization.c \ > + structs-cleanups.c \ > + structs-cleanups.h \ > + stubs-0.c \ > + stubs-1.c \ > + stubs-2.c \ > + stubs-3.c \ > + stubs-4.c \ > + stubs-5.c \ > + stubs-6.c \ > + stubs.hHm why the duplication here? I mean, I see generator_built has callbacks.ml, and types.ml -- could it be possible to add a new variable? (or use BUILT_SOURCES in generator_built, maybe)> +OCAML_LIBS = \ > + -lmlcutils \ > + -lmlstdutils \ > + -lmlhivex \ > + -lcamlstr \ > + -lunix \ > + -l$(CAMLRUN) -ldl -lmAre ld and m needed?> diff --git a/daemon/chroot.mli b/daemon/chroot.mli > new file mode 100644 > index 000000000..eda3a785f > --- /dev/null > +++ b/daemon/chroot.mli > @@ -0,0 +1,35 @@ > +(* guestfs-inspection > + * Copyright (C) 2009-2017 Red Hat Inc. > + * > + * This program is free software; you can redistribute it and/or modify > + * it under the terms of the GNU General Public License as published by > + * the Free Software Foundation; either version 2 of the License, or > + * (at your option) any later version. > + * > + * This program is distributed in the hope that it will be useful, > + * but WITHOUT ANY WARRANTY; without even the implied warranty of > + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the > + * GNU General Public License for more details. > + * > + * You should have received a copy of the GNU General Public License along > + * with this program; if not, write to the Free Software Foundation, Inc., > + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. > + *) > + > +(** This is a generic module for running functions in a chroot. > + The function runs in a forked subprocess too so that we can > + restore the root afterwards. > + > + It handles passing the parmeter, forking, running thetypo, "parameter"> + function and marshalling the result or any exceptions. *) > + > +type t > + > +val create : ?name:string -> string -> t > +(** Create a chroot handle. [?name] is an optional name used in > + debugging and error messages. The string is the chroot > + directory. *) > + > +val f : t -> ('a -> 'b) -> 'a -> 'b > +(** Run a function in the chroot, returning the result or re-raising > + any exception thrown. *)After reading patch #11, IMHO there should be a variant that takes a generic (unit -> unit) function (called 'fn', maybe?), and have 'f' use it: let f t fun arg f (fun () -> fun arg)> diff --git a/daemon/guestfsd.c b/daemon/guestfsd.c > index b3f40628b..1d35991b6 100644 > --- a/daemon/guestfsd.c > +++ b/daemon/guestfsd.c > @@ -56,6 +56,10 @@ > > #include <augeas.h> > > +#include <caml/callback.h> > +#include <caml/mlvalues.h> > +#include <caml/unixsupport.h> > + > #include "sockets.h" > #include "c-ctype.h" > #include "ignore-value.h" > @@ -348,6 +352,9 @@ main (int argc, char *argv[]) > */ > udev_settle (); > > + /* Initialize the OCaml stubs. */ > + caml_startup (argv); > + > /* Send the magic length message which indicates that > * userspace is up inside the guest. > */ > @@ -1205,3 +1212,46 @@ cleanup_free_mountable (mountable_t *mountable) > free (mountable->volume); > } > } > + > +/* Convert an OCaml exception to a reply_with_error_errno call > + * as best we can. > + */ > +extern void ocaml_exn_to_reply_with_error (const char *func, value exn); > + > +void > +ocaml_exn_to_reply_with_error (const char *func, value exn) > +{Shouldn't this use CAMLparam1 + CAMLreturn?> 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) > +{Ditto.> diff --git a/daemon/utils.ml b/daemon/utils.ml > new file mode 100644 > index 000000000..7630a5534 > --- /dev/null > +++ b/daemon/utils.ml > @@ -0,0 +1,156 @@ > +(* guestfs-inspection > + * Copyright (C) 2009-2017 Red Hat Inc. > + * > + * This program is free software; you can redistribute it and/or modify > + * it under the terms of the GNU General Public License as published by > + * the Free Software Foundation; either version 2 of the License, or > + * (at your option) any later version. > + * > + * This program is distributed in the hope that it will be useful, > + * but WITHOUT ANY WARRANTY; without even the implied warranty of > + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the > + * GNU General Public License for more details. > + * > + * You should have received a copy of the GNU General Public License along > + * with this program; if not, write to the Free Software Foundation, Inc., > + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. > + *) > + > +open Unix > +open Printf > + > +open Std_utils > + > +let prog_exists prog > + try ignore (which prog); true > + with Executable_not_found _ -> false > + > +let commandr prog argsAnother option here, instead of the manual implementation, would be to bind the C command* APIs -- this way there is no need to do fixes & additions in both places.> + if verbose () then > + eprintf "command: %s %s\n%!" > + prog (String.concat " " args);stringify_args could help here.> + let argv = Array.of_list (prog :: args) in > + > + let stdout_file, stdout_chan = Filename.open_temp_file "cmd" ".out" in > + let stderr_file, stderr_chan = Filename.open_temp_file "cmd" ".err" in > + let stdout_fd = descr_of_out_channel stdout_chan in > + let stderr_fd = descr_of_out_channel stderr_chan in > + let stdin_fd = openfile "/dev/null" [O_RDONLY] 0 in > + > + let pid = fork () in > + if pid = 0 then ( > + (* Child process. *) > + dup2 stdin_fd stdin; > + close stdin_fd; > + dup2 stdout_fd stdout; > + close stdout_fd; > + dup2 stderr_fd stderr; > + close stderr_fd; > + > + execvp prog argv > + ); > + > + (* Parent process. *) > + close stdin_fd; > + close stdout_fd; > + close stderr_fd; > + let _, status = waitpid [] pid in > + let r > + match status with > + | WEXITED i -> i > + | WSIGNALED i -> > + failwithf "external command ‘%s’ killed by signal %d" prog i > + | WSTOPPED i -> > + failwithf "external command ‘%s’ stopped by signal %d" prog i in > + > + if verbose () then > + eprintf "command: %s returned %d\n" prog r; > + > + let stdout = read_whole_file stdout_file in > + let stderr = read_whole_file stderr_file in > + > + if verbose () then ( > + if stdout <> "" then ( > + eprintf "command: %s: stdout:\n%s%!" prog stdout; > + if not (String.is_suffix stdout "\n") then eprintf "\n%!" > + ); > + if stderr <> "" then ( > + eprintf "command: %s: stderr:\n%s%!" prog stderr; > + if not (String.is_suffix stderr "\n") then eprintf "\n%!" > + ) > + ); > + > + (* Strip trailing \n from stderr but NOT from stdout. *) > + let stderr > + let n = String.length stderr in > + if n > 0 && stderr.[n-1] = '\n' then > + String.sub stderr 0 (n-1) > + else > + stderr inThis bit is already done in v2v/linux_bootloaders.ml, get_default_image helper function; can you please move that to a chop function in Std_utils? Most probably it could be used in Common_utils.uuidgen as well. (Also, funny thing is that, while grepping for that, I noticed the C equivalent is written in many places, all around daemon, library, and tools...)> + > + (r, stdout, stderr) > + > +let command prog args > + let r, stdout, stderr = commandr prog args in > + if r <> 0 then > + failwithf "%s exited with status %d: %s" prog r stderr; > + stdout > + > +let udev_settle ?filename ()Ditto.> + 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 * 1024There could be an helper function sysroot_path, to mimick the C function with the same name, and simplify code like let mp = Sysroot.sysroot () // mountpoint in into let mp = sysroot_path mountpoint in -- Pino Toscano
Pino Toscano
2017-Jul-19 13:14 UTC
Re: [Libguestfs] [PATCH 03/27] daemon: Reimplement ‘file’ API in OCaml.
On Friday, 14 July 2017 15:39:11 CEST Richard W.M. Jones wrote:> 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);When migrating to OCaml, these extra sections in the ELF are not added anymore. I read they were added to help packagers (IIRC it started from the SUSE guys), so they could easily notice the binaries used by the daemon, and add the proper dependencies. Do we still want to keep this possibility, somehow? If not, I'd just do a wholesale removal of GUESTFSD_EXT_CMD.> + if not is_dev then ( > + let sysroot = Sysroot.sysroot () in > + let chroot = Chroot.create sysroot ~name:(sprintf "file: %s" path) inI notice this pattern done every time, and IMHO it could be simplified: in utils.ml(i), add something like: let create_chroot ?name () Chroot.create (Sysroot.sysroot ()) ?name this way it can be used like: let chroot = create_chroot ~name:(sprintf "file: %s" path) in> + > + let statbuf = Chroot.f chroot lstat path inHm is chroot needed for this? The current C implementation does not use CHROOT_IN/OUT, and it does not even resolve symlinks, so it should be safe. -- Pino Toscano
Pino Toscano
2017-Jul-19 13:15 UTC
Re: [Libguestfs] [PATCH 04/27] daemon: Reimplement ‘vfs_type’ API in OCaml.
On Friday, 14 July 2017 15:39:12 CEST Richard W.M. Jones wrote:> +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.trimr out > + > + | 2 -> (* means tag not found, we return "" *) > + "" > + > + | _ -> > + failwithf "blkid: %s: %s" tag errCould you please add the device in the error message, like done in the C implementation?> @@ -641,13 +674,14 @@ extern void ocaml_exn_to_reply_with_error (const char *func, value exn); > | RBool _ -> assert false > | RConstString _ -> assert false > | RConstOptString _ -> assert false > - | RString _ -> > + | RString (RPlainString, _) -> > 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 _ -> assert falseCould you please move these changes in patch #2? -- Pino Toscano
Pino Toscano
2017-Jul-19 13:17 UTC
Re: [Libguestfs] [PATCH 05/27] daemon: Reimplement several devsparts APIs in OCaml.
On Friday, 14 July 2017 15:39:13 CEST Richard W.M. Jones wrote:> + let devs > + List.filter ( > + fun dev -> > + try close (openfile ("/dev/" ^ dev) [O_RDONLY; O_CLOEXEC] 0); trueNote Unix.O_CLOEXEC does not exist in OCaml < 4, see also commit ece9c35e58a3ba18ac9bed955251482bb774ab97.> + let devices > + map_block_devices ~return_md:false (fun dev -> "/dev/" ^ dev) inThis IIRC can be simplified slightly: 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 (fun part -> "/dev/" ^ part) partsDitto: List.map ((^) "/dev/") parts> + (* 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) inIsn't this a bit more complicated than a simpler: let r = (String.length dev_b) - (String.length dev_a) in ?> diff --git a/generator/daemon.ml b/generator/daemon.ml > index 121634806..3ffe91537 100644 > --- a/generator/daemon.ml > +++ b/generator/daemon.ml > @@ -553,6 +553,26 @@ copy_mountable (const mountable_t *mountable) > CAMLreturn (r); > } > > +/* Implement RStringList. */ > +static char ** > +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 */ > +} > + > "; > > List.iter ( > @@ -669,12 +689,14 @@ copy_mountable (const mountable_t *mountable) > > (match ret with > | RErr -> assert false > - | RInt _ -> assert false > + | RInt _ -> > + pr " CAMLreturnT (int, Int_val (retv));\n" > | RInt64 _ -> assert false > - | RBool _ -> assert false > + | RBool _ -> > + pr " CAMLreturnT (int, Bool_val (retv));\n" > | RConstString _ -> assert false > | RConstOptString _ -> assert false > - | RString (RPlainString, _) -> > + | RString ((RPlainString|RDevice), _) -> > pr " char *ret = strdup (String_val (retv));\n"; > pr " if (ret == NULL) {\n"; > pr " reply_with_perror (\"strdup\");\n"; > @@ -682,7 +704,9 @@ copy_mountable (const mountable_t *mountable) > pr " }\n"; > pr " CAMLreturnT (char *, ret); /* caller frees */\n" > | RString _ -> assert false > - | RStringList _ -> assert false > + | RStringList _ -> > + pr " char **ret = return_string_list (retv);\n"; > + pr " CAMLreturnT (char **, ret); /* caller frees */\n" > | RStruct _ -> assert false > | RStructList _ -> assert false > | RHashtable _ -> assert falseIMHO all the changes above would fit in patch #2 already, although here is fine too. -- Pino Toscano
Pino Toscano
2017-Jul-19 13:17 UTC
Re: [Libguestfs] [PATCH 07/27] daemon: Reimplement ‘is_dir’, ‘is_file’ and ‘is_symlink’ APIs in OCaml.
On Friday, 14 July 2017 15:39:15 CEST Richard W.M. Jones wrote:> +let rec is_file ?(followsymlinks = false) path > + let sysroot = Sysroot.sysroot () in > + let chroot = Chroot.create sysroot ~name:(sprintf "is_file: %s" path) in > + Chroot.f chroot get_kind (path, followsymlinks) = Some S_REG > + > +and is_dir ?(followsymlinks = false) path > + let sysroot = Sysroot.sysroot () in > + let chroot = Chroot.create sysroot ~name:(sprintf "is_dir: %s" path) in > + Chroot.f chroot get_kind (path, followsymlinks) = Some S_DIR > + > +and is_symlink path > + let sysroot = Sysroot.sysroot () in > + let chroot = Chroot.create sysroot ~name:(sprintf "is_symlink: %s" path) in > + Chroot.f chroot get_kind (path, false) = Some S_LNKWould it be possible to factorize even more of the code for these functions? Something like (untested): let check_type ~followsymlinks path func_string typ let sysroot = Sysroot.sysroot () in let chroot = Chroot.create sysroot ~name:(sprintf "%s: %s" func_string path) in Chroot.f chroot get_kind (path, followsymlinks) = Some S_DIR let statfun = if followsymlinks then stat else lstat in try let statbuf = statfun path in statbuf.st_kind = typ with Unix_error ((ENOENT|ENOTDIR), _, _) -> false (* File doesn't exist => return false *) let is_file ?(followsymlinks = false) path check_type path ~followsymlinks "is_file" S_REG let is_symlink path check_type path ~followsymlinks:false "is_symlink" S_LNK -- Pino Toscano
Pino Toscano
2017-Jul-19 13:18 UTC
Re: [Libguestfs] [PATCH 09/27] daemon: Reimplement ‘mount’, ‘mount_ro’, ‘mount_options’, ‘mount_vfs’ APIs in OCaml.
On Friday, 14 July 2017 15:39:17 CEST Richard W.M. Jones wrote:> diff --git a/generator/daemon.ml b/generator/daemon.ml > index ef6086bfe..fd01e5d8a 100644 > --- a/generator/daemon.ml > +++ b/generator/daemon.ml > @@ -689,7 +689,8 @@ return_string_list (value retv) > pr "\n"; > > (match ret with > - | RErr -> assert false > + | RErr -> > + pr " CAMLreturnT (int, 0);\n"This might fit in patch #2 as well. -- Pino Toscano
Pino Toscano
2017-Jul-19 13:18 UTC
Re: [Libguestfs] [PATCH 10/27] daemon: Reimplement ‘part_get_mbr_id’ API in OCaml.
On Friday, 14 July 2017 15:39:18 CEST Richard W.M. Jones wrote:> +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" identityI see that the C sscanf discards the leading spaces, so maybe it would be safer to use String.triml to behave the same, and not break in case sfdisk changes its output in the future. -- Pino Toscano
Pino Toscano
2017-Jul-19 13:20 UTC
Re: [Libguestfs] [PATCH 12/27] daemon: Reimplement ‘file_architecture’ API in OCaml.
On Friday, 14 July 2017 15:39:20 CEST Richard W.M. Jones wrote:> +(* Convert output from 'file' command on ELF files to the canonical > + * architecture string. Caller must free the result.No more need to free anything, I guess?> +and cpio_arch magic orig_path path > + let sysroot = Sysroot.sysroot () in > + > + 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 = sprintf "/tmp/%s" (String.random8 ()) in > + mkdir tmpdir 0o700;This could use Mkdtemp.temp_dir (from mlutils, Unix_utils). Even if there is not much advantage, at least it makes slightly easier to read the code, and to discover where temporary directories are created.> + (* 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 // 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_binariesThis must cleanup tmpdir, otherwise things will pile up and fill the appliance.> diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES > index 6149bba43..2dbd5a14b 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,7 @@ daemon/compress.c > daemon/copy.c > daemon/cpio.c > daemon/cpmv.c > +daemon/daemon-c.c > daemon/daemon.h > daemon/dd.c > daemon/debug-bmap.c > @@ -173,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 > @@ -296,7 +299,6 @@ lib/errors.cThe three hunks above should be part of patch #2. -- Pino Toscano
Pino Toscano
2017-Jul-19 13:20 UTC
Re: [Libguestfs] [PATCH 13/27] daemon: Reimplement ‘list_ldm_(volumes|partitions)’ APIs in OCaml.
On Friday, 14 July 2017 15:39:21 CEST Richard W.M. Jones wrote:> +(* All device mapper devices are 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. > + *) > +let list_ldm_volumes () > + (* 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 "ldm_vol_") dir in > + let dir = List.map ((^) "/dev/mapper/") dir in > + List.sort compare dir > + ) > + > +(* Same as above but /dev/mapper/ldm_part_*. *) > +let list_ldm_partitions () > + (* 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 "ldm_part_") dir in > + let dir = List.map ((^) "/dev/mapper/") dir in > + List.sort compare dir > + )IMHO most of their code can be shared, like done in the C implementations -- something like the following (untested): let get_devices 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 ) let list_ldm_volumes () get_devices "ldm_vol_" let list_ldm_partitions () get_devices "ldm_part_" -- Pino Toscano
Pino Toscano
2017-Jul-19 13:21 UTC
Re: [Libguestfs] [PATCH 14/27] daemon: Reimplement ‘lvs’ API in OCaml.
On Friday, 14 July 2017 15:39:22 CEST Richard W.M. Jones wrote:> +let lvs_has_S_opt = lazy ( > + let out = command "lvm" ["lvs"; "--help"] in > + String.find out "-S" >= 0 > +)Could you please add the comment for this? (* Check whether lvs has -S to filter its output. * It is available only in lvm2 >= 2.02.107. *)> +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 = List.map ((^) prefix) lines inA small optimization here could be to avoid the map if the prefix is empty: let lines if prefix <> "" then List.map ((^) prefix) lines else lines in (or even not giving ?prefix a default value, and matching on None/Some) -- Pino Toscano
Pino Toscano
2017-Jul-20 15:07 UTC
Re: [Libguestfs] [PATCH 16/27] daemon: Generate OCaml wrappers for optgroup_*_available functions.
On Friday, 14 July 2017 15:39:24 CEST Richard W.M. Jones wrote:> It is sometimes useful to be able to call these from OCaml code. > --- > generator/daemon.ml | 23 ++++++++++++++++++++++- > 1 file changed, 22 insertions(+), 1 deletion(-)I see in patch #19: external available : unit -> bool "guestfs_int_daemon_optgroup_lvm2_available" "noalloc" I think it'd be better to generate daemon/optgroups.ml{,i} instead, so there is no need for manual extern declarations.> diff --git a/generator/daemon.ml b/generator/daemon.ml > index fd01e5d8a..1d7461f8c 100644 > --- a/generator/daemon.ml > +++ b/generator/daemon.ml > @@ -976,6 +976,10 @@ let generate_daemon_optgroups_c () > generate_header CStyle GPLv2plus; > > pr "#include <config.h>\n"; > + pr "#include <stdio.h>\n"; > + pr "#include <stdlib.h>\n";Not a problem, but are they needed?> @@ -999,7 +1003,24 @@ 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 -> > + if not (List.mem group optgroups_retired) then ( > + 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_allI'd use 'optgroups_names' here, that contains only non-retired optgroups (thus avoiding the check in the iteration). -- Pino Toscano
Pino Toscano
2017-Jul-20 15:11 UTC
Re: [Libguestfs] [PATCH 18/27] daemon: Reimplement ‘btrfs_subvolume_list’ and ‘btrfs_subvolume_get_default’ in OCaml.
On Friday, 14 July 2017 15:39:26 CEST Richard W.M. Jones wrote:> +(* 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 with_mounted mountable f > + let tmpdir = sprintf "/tmp/%s" (String.random8 ()) inlet tmpdir = Mkdtemp.temp_dir ~base_dir:"/tmp" "btrfs." "" in (or even without ~base_dir, I guess the default should be fine.) This will also avoid the mkdir calls later on.> + (* 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 > + > + 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 () // mountable.m_device)After using Mkdtemp.temp_dir above, "rmdir tmpdir" will be needed here.> + > + | MountableDevice -> > + protect ~finally ~f:( > + fun () -> > + mkdir tmpdir 0o700; > + ignore (command "mount" [mountable.m_device; tmpdir]); > + f tmpdir > + ) > + > + | MountableBtrfsVol subvol -> > + protect ~finally ~f:( > + fun () -> > + mkdir tmpdir 0o700; > + ignore (command "mount" ["-o"; "subvol=" ^ subvol (* XXX quoting? *); > + mountable.m_device; tmpdir]); > + f tmpdir > + ) > + > +let re_btrfs_subvolume_list > + Str.regexp ("ID[ \t]+\\([0-9]+\\).*[ \t]" ^ > + "top level[ \t]+\\([0-9]+\\).*[ \t]" ^ > + "path[ \t]+\\(.*\\)")Sigh, Str does not support simple character classes like \s :( No wonder there are at least two or three "re" OCaml modules providing sane regular expression engines (with a less awkward syntax for captures, etc).> +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 inIf here we do: let lines = List.filter ((<>) "") lines in then later on we can use List.map instead of filter_map.> 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; > +}Is this needed? Could Structs.btrfssubvolume be used below? -- Pino Toscano
Pino Toscano
2017-Jul-20 15:13 UTC
Re: [Libguestfs] [PATCH 19/27] daemon: Reimplement ‘list_filesystems’ API in the daemon, in OCaml.
On Friday, 14 July 2017 15:39:27 CEST Richard W.M. Jones wrote:> +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 = List.fold_left ( > + fun devices part -> > + let d = Devsparts.part_to_dev part in > + List.filter ((<>) d) devices > + ) devices partitions inHm it took me a couple of reading to get it -- what would you think about the following (untested): module StringSet = Set.Make (String) ... let devices_of_partitions = List.fold_left ( fun set part -> StringSet.add part set ) partitions StringSet.empty in (* Remove *) let devices = List.filter ( fun dev -> not (StringSet.mem dev devices_of_partitions) ) devices in let devices = devices @ partitions 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 inNow this will run is_mbr_partition_type_42 on devices as well, in case ldm is available -- I guess it should not be an issue? -- Pino Toscano
Pino Toscano
2017-Jul-20 15:15 UTC
Re: [Libguestfs] [PATCH 20/27] daemon: Reimplement ‘part_list’ API in OCaml.
On Friday, 14 July 2017 15:39:28 CEST Richard W.M. Jones wrote:> +let print_partition_table ~add_m_option device > + udev_settle (); > + > + let args = ref [] in > + if add_m_option then 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"Note the first two lines with "BYT;", and the device name must be filtered only when running in machine-parseable mode, otherwise the match above will fail (since the output is very different in non-machine-parseable mode). The other option is making this function always use -m, and implement a separate print_partition_table only in case part_get_mbr_part_type is ported to OCaml (since it's the single user of it).> 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; > +}Is this needed? Could Structs.partition be used below? -- Pino Toscano
Pino Toscano
2017-Jul-20 15:15 UTC
Re: [Libguestfs] [PATCH 23/27] daemon: Reimplement ‘md_detail’ API in OCaml.
On Friday, 14 July 2017 15:39:31 CEST Richard W.M. Jones wrote:> +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 inIf here we do: let lines = List.filter ((<>) "") lines in then later on we can use List.map instead of filter_map. -- Pino Toscano
Reasonably Related Threads
- [PATCH 2/2] ocaml: fix build with Bytes fallback
- [PATCH] configure: Move language binding detection to separate files.
- [PATCH] build: require ocaml-hivex for the daemon
- [PATCH 2/2] configure: simplify check for oUnit v2
- Re: [PATCH 1/4] ocaml: Use generational global roots.