[Libguestfs] [PATCH v6 17/41] daemon: Reimplement ‘vfs_type’ API in OCaml.

Richard W.M. Jones
Thu, 15 Jun 2017 17:06:07 -0000

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 f354a0d6f..fc99c500f 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -257,16 +257,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.0