1 (* 'df' command for virtual domains.
8 module C = Libvirt.Connect
9 module D = Libvirt.Domain
10 module N = Libvirt.Network
15 (* Command line argument parsing. *)
16 let set_uri = function "" -> uri := None | u -> uri := Some u in
18 let argspec = Arg.align [
19 "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)";
20 "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)";
23 let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in
24 let usage_msg = "virt-df : like 'df', shows disk space used in guests
31 Arg.parse argspec anon_fun usage_msg
34 (* Connect to the hypervisor. *)
37 try C.connect_readonly ?name ()
39 Libvirt.Virterror err ->
40 prerr_endline (Libvirt.Virterror.to_string err);
41 (* If non-root and no explicit connection URI, print a warning. *)
42 if Unix.geteuid () <> 0 && name = None then (
43 print_endline "NB: If you want to monitor a local Xen hypervisor, you usually need to be root";
47 (* Get the list of active & inactive domains. *)
49 let nr_active_doms = C.num_of_domains conn in
50 let active_doms = Array.to_list (C.list_domains conn nr_active_doms) in
51 let active_doms = List.map (D.lookup_by_id conn) active_doms in
52 let nr_inactive_doms = C.num_of_defined_domains conn in
54 Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
55 let inactive_doms = List.map (D.lookup_by_name conn) inactive_doms in
56 active_doms @ inactive_doms in
59 let xmls = List.map D.get_xml_desc doms in
62 let xmls = List.map Xml.parse_string xmls in
64 (* Return just the XML documents - everything else will be closed
65 * and freed including the connection to the hypervisor.
69 (* Parse out the device XML to get the names of disks. *)
71 dom_name : string; (* Domain name. *)
72 dom_id : int option; (* Domain ID (if running). *)
73 dom_disks : disk list; (* Domain disks. *)
76 d_type : string option; (* The <disk type=...> *)
77 d_device : string option; (* The <disk device=...> *)
78 d_file : string option; (* The <source file=...> *)
79 d_dev : string option; (* The <target dev=...> *)
82 let doms : domain list =
83 (* Grr.. Need to use a library which has XPATH support (or cduce). *)
86 let nodes, domain_attrs =
88 | Xml.Element ("domain", attrs, children) -> children, attrs
89 | _ -> failwith "get_xml_desc didn't return <domain/>" in
92 try Some (int_of_string (List.assoc "id" domain_attrs))
93 with Not_found -> None in
95 let rec loop = function
97 failwith "get_xml_desc returned no <name> node in XML"
98 | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
99 | Xml.Element ("name", _, _) :: _ ->
100 failwith "get_xml_desc returned strange <name> node"
101 | _ :: rest -> loop rest
103 let name = loop nodes in
109 | Xml.Element ("devices", _, devices) -> Some devices
112 List.concat devices in
114 let rec target_dev_of = function
116 | Xml.Element ("target", attrs, _) :: rest ->
117 (try Some (List.assoc "dev" attrs)
118 with Not_found -> target_dev_of rest)
119 | _ :: rest -> target_dev_of rest
122 let rec source_file_of = function
124 | Xml.Element ("source", attrs, _) :: rest ->
125 (try Some (List.assoc "file" attrs)
126 with Not_found -> source_file_of rest)
127 | _ :: rest -> source_file_of rest
133 | Xml.Element ("disk", attrs, children) ->
135 try Some (List.assoc "type" attrs)
136 with Not_found -> None in
138 try Some (List.assoc "device" attrs)
139 with Not_found -> None in
140 let file = source_file_of children in
141 let dev = target_dev_of children in
144 d_type = typ; d_device = device; d_file = file; d_dev = dev
149 { dom_name = name; dom_id = domid; dom_disks = disks }
152 (* Print the domains / devices. *)
155 fun { dom_name = dom_name; dom_disks = dom_disks } ->
156 printf "%s:\n" dom_name;
159 | { d_file = Some file; d_dev = Some dev } ->
160 printf "\t%s -> %s\n" file dev
162 printf "\t(device omitted, missing <source> or <target> in XML\n";