diff options
Diffstat (limited to 'virt-df/virt_df.ml')
| -rw-r--r-- | virt-df/virt_df.ml | 164 |
1 files changed, 164 insertions, 0 deletions
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 |