Basic version, just prints the domains and disk/file mappings.

2 files changed, 231 insertions, 0 deletions

diff --git a/virt-df/Makefile.in b/virt-df/Makefile.in
new file mode 100644
index 0000000..ed820e6
--- /dev/null
+++ b/virt-df/Makefile.in
@@ -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
index 0000000..26c73c6
--- /dev/null
+++ b/virt-df/virt_df.ml
@@ -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