diff options
| -rw-r--r-- | .hgignore | 2 | ||||
| -rw-r--r-- | Makefile.in | 5 | ||||
| -rw-r--r-- | configure.ac | 7 | ||||
| -rw-r--r-- | virt-df/Makefile.in | 67 | ||||
| -rw-r--r-- | virt-df/virt_df.ml | 164 |
5 files changed, 245 insertions, 0 deletions
@@ -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 diff --git a/Makefile.in b/Makefile.in index 3ad12ac..fedf443 100644 --- a/Makefile.in +++ b/Makefile.in @@ -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 $@; \ diff --git a/configure.ac b/configure.ac index f1dc5c8..a330327 100644 --- a/configure.ac +++ b/configure.ac @@ -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 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 |