Basic version, just prints the domains and disk/file mappings.
authorrjones@amd <rjones@amd>
Tue, 4 Sep 2007 16:39:43 +0000 (17:39 +0100)
committerrjones@amd <rjones@amd>
Tue, 4 Sep 2007 16:39:43 +0000 (17:39 +0100)
.hgignore
Makefile.in
configure.ac
virt-df/Makefile.in [new file with mode: 0644]
virt-df/virt_df.ml [new file with mode: 0644]

index 1d962d2..2c73f54 100644 (file)
--- a/.hgignore
+++ b/.hgignore
@@ -20,8 +20,10 @@ core.*
 *.so
 *.a
 *.opt
+*~
 libvirt/libvirt_version.ml
 examples/list_domains
 mlvirsh/mlvirsh
 mlvirtmanager/mlvirtmanager
 virt-top/virt-top
+virt-df/virt-df
index 3ad12ac..fedf443 100644 (file)
@@ -7,6 +7,7 @@ INSTALL         = @INSTALL@
 
 pkg_lablgtk2   = @pkg_lablgtk2@
 pkg_curses     = @pkg_curses@
+pkg_xml_light  = @pkg_xml_light@
 
 OCAMLDOCFLAGS  := -html -sort
 
@@ -20,6 +21,10 @@ ifeq ($(pkg_curses),yes)
 SUBDIRS                += virt-top
 endif
 
+ifeq ($(pkg_xml_light),yes)
+SUBDIRS                += virt-df
+endif
+
 all opt depend install:
        for d in $(SUBDIRS); do \
          $(MAKE) -C $$d $@; \
index f1dc5c8..a330327 100644 (file)
@@ -88,6 +88,12 @@ if test "x$pkg_curses" = "xyes"; then
 else
    echo "no (needs optional ocaml-curses)"
 fi
+echo -n "  virt-df      . . . . . . . "
+if test "x$pkg_xml_light" = "xyes"; then
+   echo "yes"
+else
+   echo "no (needs optional xml-light)"
+fi
 echo "------------------------------------------------------------"
 
 dnl Produce output files.
@@ -100,5 +106,6 @@ AC_CONFIG_FILES([META
        mlvirsh/Makefile
        mlvirtmanager/Makefile
        virt-top/Makefile
+       virt-df/Makefile
        ])
 AC_OUTPUT
diff --git a/virt-df/Makefile.in b/virt-df/Makefile.in
new file mode 100644 (file)
index 0000000..ed820e6
--- /dev/null
@@ -0,0 +1,67 @@
+# $Id: Makefile.in,v 1.6 2007/08/23 11:09:19 rjones Exp $
+
+PACKAGE                := @PACKAGE_NAME@
+VERSION                := @PACKAGE_VERSION@
+
+INSTALL                := @INSTALL@
+HAVE_PERLDOC   := @HAVE_PERLDOC@
+
+prefix         = @prefix@
+exec_prefix    = @exec_prefix@
+bindir         = @bindir@
+
+pkg_xml_light  = @pkg_xml_light@
+
+OCAMLCPACKAGES := -package unix,extlib,xml-light
+
+OBJS           := virt_df.cmo
+XOBJS          := $(OBJS:.cmo=.cmx)
+
+OCAMLCPACKAGES  += -I ../libvirt
+OCAMLCFLAGS    := -g -w s
+OCAMLCLIBS     := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS  := -w s
+OCAMLOPTLIBS   := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=../libvirt
+export LD_LIBRARY_PATH=../libvirt
+
+BYTE_TARGETS   := virt-df
+OPT_TARGETS    := virt-df.opt
+
+#ifeq ($(HAVE_PERLDOC),perldoc)
+#BYTE_TARGETS  += virt-top.1 virt-top.txt
+#endif
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+virt-df: $(OBJS)
+       ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+         ../libvirt/mllibvirt.cma -o $@ $^
+
+virt-df.opt: $(XOBJS)
+       ocamlfind ocamlopt \
+         $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+         ../libvirt/mllibvirt.cmxa -cclib -lncurses -o $@ $^
+
+# Manual page.
+#ifeq ($(HAVE_PERLDOC),perldoc)
+#virt-top.1: virt-top.pod
+#      pod2man -c "Virtualization Support" --release "$(PACKAGE)-$(VERSION)" \
+#              $< > $@
+#
+#virt-top.txt: virt-top.pod
+#      pod2text $< > $@
+#endif
+
+install:
+       if [ -x virt-df.opt ]; then \
+         mkdir -p $(DESTDIR)$(bindir); \
+         $(INSTALL) -m 0755 virt-df.opt $(DESTDIR)$(bindir)/virt-df; \
+       fi
+
+include ../Make.rules
diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml
new file mode 100644 (file)
index 0000000..26c73c6
--- /dev/null
@@ -0,0 +1,164 @@
+(* 'df' command for virtual domains.
+ * $Id$
+ *)
+
+open Printf
+open ExtList
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module N = Libvirt.Network
+
+let uri = ref None
+
+let () =
+  (* Command line argument parsing. *)
+  let set_uri = function "" -> uri := None | u -> uri := Some u in
+
+  let argspec = Arg.align [
+    "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)";
+    "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)";
+  ] in
+
+  let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in
+  let usage_msg = "virt-df : like 'df', shows disk space used in guests
+
+SUMMARY
+  virt-df [-options]
+
+OPTIONS" in
+
+  Arg.parse argspec anon_fun usage_msg
+
+let xmls =
+  (* Connect to the hypervisor. *)
+  let conn =
+    let name = !uri in
+    try C.connect_readonly ?name ()
+    with
+      Libvirt.Virterror err ->
+       prerr_endline (Libvirt.Virterror.to_string err);
+       (* If non-root and no explicit connection URI, print a warning. *)
+       if Unix.geteuid () <> 0 && name = None then (
+         print_endline "NB: If you want to monitor a local Xen hypervisor, you usually need to be root";
+       );
+       exit 1 in
+
+  (* Get the list of active & inactive domains. *)
+  let doms =
+    let nr_active_doms = C.num_of_domains conn in
+    let active_doms = Array.to_list (C.list_domains conn nr_active_doms) in
+    let active_doms = List.map (D.lookup_by_id conn) active_doms in
+    let nr_inactive_doms = C.num_of_defined_domains conn in
+    let inactive_doms =
+      Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
+    let inactive_doms = List.map (D.lookup_by_name conn) inactive_doms in
+    active_doms @ inactive_doms in
+
+  (* Get their XML. *)
+  let xmls = List.map D.get_xml_desc doms in
+
+  (* Parse the XML. *)
+  let xmls = List.map Xml.parse_string xmls in
+
+  (* Return just the XML documents - everything else will be closed
+   * and freed including the connection to the hypervisor.
+   *)
+  xmls
+
+(* Parse out the device XML to get the names of disks. *)
+type domain = {
+  dom_name : string;                   (* Domain name. *)
+  dom_id : int option;                 (* Domain ID (if running). *)
+  dom_disks : disk list;               (* Domain disks. *)
+}
+and disk = {
+  d_type : string option;              (* The <disk type=...> *)
+  d_device : string option;            (* The <disk device=...> *)
+  d_file : string option;              (* The <source file=...> *)
+  d_dev : string option;               (* The <target dev=...> *)
+}
+
+let doms : domain list =
+  (* Grr.. Need to use a library which has XPATH support (or cduce). *)
+  List.map (
+    fun xml ->
+      let nodes, domain_attrs =
+       match xml with
+       | Xml.Element ("domain", attrs, children) -> children, attrs
+       | _ -> failwith "get_xml_desc didn't return <domain/>" in
+
+      let domid =
+       try Some (int_of_string (List.assoc "id" domain_attrs))
+       with Not_found -> None in
+
+      let rec loop = function
+       | [] ->
+           failwith "get_xml_desc returned no <name> node in XML"
+       | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
+       | Xml.Element ("name", _, _) :: _ ->
+           failwith "get_xml_desc returned strange <name> node"
+       | _ :: rest -> loop rest
+      in
+      let name = loop nodes in
+
+      let devices =
+       let devices =
+         List.filter_map (
+           function
+           | Xml.Element ("devices", _, devices) -> Some devices
+           | _ -> None
+         ) nodes in
+       List.concat devices in
+
+      let rec target_dev_of = function
+       | [] -> None
+       | Xml.Element ("target", attrs, _) :: rest ->
+           (try Some (List.assoc "dev" attrs)
+            with Not_found -> target_dev_of rest)
+       | _ :: rest -> target_dev_of rest
+      in
+
+      let rec source_file_of = function
+       | [] -> None
+       | Xml.Element ("source", attrs, _) :: rest ->
+           (try Some (List.assoc "file" attrs)
+            with Not_found -> source_file_of rest)
+       | _ :: rest -> source_file_of rest
+      in
+
+      let disks =
+       List.filter_map (
+         function
+         | Xml.Element ("disk", attrs, children) ->
+             let typ =
+               try Some (List.assoc "type" attrs)
+               with Not_found -> None in
+             let device =
+               try Some (List.assoc "device" attrs)
+               with Not_found -> None in
+             let file = source_file_of children in
+             let dev = target_dev_of children in
+
+             Some {
+               d_type = typ; d_device = device; d_file = file; d_dev = dev
+             }
+         | _ -> None
+       ) devices in
+
+      { dom_name = name; dom_id = domid; dom_disks = disks }
+  ) xmls
+
+(* Print the domains / devices. *)
+let () =
+  List.iter (
+    fun { dom_name = dom_name; dom_disks = dom_disks } ->
+      printf "%s:\n" dom_name;
+      List.iter (
+       function
+       | { d_file = Some file; d_dev = Some dev } ->
+           printf "\t%s -> %s\n" file dev
+       | _ ->
+           printf "\t(device omitted, missing <source> or <target> in XML\n";
+      ) dom_disks
+  ) doms