1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
(* '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_source : string option; (* The <source file=... or dev> *)
d_target : 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 rec source_dev_of = function
| [] -> None
| Xml.Element ("source", attrs, _) :: rest ->
(try Some (List.assoc "dev" attrs)
with Not_found -> source_dev_of rest)
| _ :: rest -> source_dev_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 source =
match source_file_of children with
| (Some _) as source -> source
| None -> source_dev_of children in
let target = target_dev_of children in
Some {
d_type = typ; d_device = device;
d_source = source; d_target = target
}
| _ -> 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_source = Some source; d_target = Some target } ->
printf "\t%s -> %s\n" source target
| { d_type = None; d_device = Some "cdrom";
d_source = None; d_target = Some target } ->
printf "\t[CD] -> %s\n" target
| _ ->
printf "\t(device omitted, missing <source> or <target> in XML\n";
) dom_disks
) doms
|
