1 (* 'df' command for virtual domains.
2 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
24 module C = Libvirt.Connect
25 module D = Libvirt.Domain
27 open Virt_df_gettext.Gettext
31 (* Command line argument parsing. *)
32 let set_uri = function "" -> uri := None | u -> uri := Some u in
35 printf "virt-df %s\n" (Libvirt_version.version);
37 let major, minor, release =
38 let v, _ = Libvirt.get_version () in
39 v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
40 printf "libvirt %d.%d.%d\n" major minor release;
44 let test_mode filename =
45 test_files := filename :: !test_files
48 let argspec = Arg.align [
50 " " ^ s_ "Show all domains (default: only active domains)";
52 " " ^ s_ "Show all domains (default: only active domains)";
53 "-c", Arg.String set_uri,
54 "uri " ^ s_ "Connect to URI (default: Xen)";
55 "--connect", Arg.String set_uri,
56 "uri " ^ s_ "Connect to URI (default: Xen)";
58 " " ^ s_ "Print sizes in human-readable format";
59 "--human-readable", Arg.Set human,
60 " " ^ s_ "Print sizes in human-readable format";
62 " " ^ s_ "Show inodes instead of blocks";
63 "--inodes", Arg.Set inodes,
64 " " ^ s_ "Show inodes instead of blocks";
65 "-t", Arg.String test_mode,
66 "dev" ^ s_ "(Test mode) Display contents of block device or file";
67 "--version", Arg.Unit version,
68 " " ^ s_ "Display version and exit";
72 raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
73 let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests
80 Arg.parse argspec anon_fun usage_msg;
82 let doms : domain list =
83 if !test_files = [] then (
85 (* Connect to the hypervisor. *)
88 try C.connect_readonly ?name ()
90 Libvirt.Virterror err ->
91 prerr_endline (Libvirt.Virterror.to_string err);
92 (* If non-root and no explicit connection URI, print a warning. *)
93 if geteuid () <> 0 && name = None then (
94 print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
98 (* Get the list of active & inactive domains. *)
100 let nr_active_doms = C.num_of_domains conn in
102 Array.to_list (C.list_domains conn nr_active_doms) in
104 List.map (D.lookup_by_id conn) active_doms in
108 let nr_inactive_doms = C.num_of_defined_domains conn in
110 Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
112 List.map (D.lookup_by_name conn) inactive_doms in
113 active_doms @ inactive_doms
117 let xmls = List.map D.get_xml_desc doms in
120 let xmls = List.map Xml.parse_string xmls in
122 (* Return just the XML documents - everything else will be closed
123 * and freed including the connection to the hypervisor.
127 (* Grr.. Need to use a library which has XPATH support (or cduce). *)
130 let nodes, domain_attrs =
132 | Xml.Element ("domain", attrs, children) -> children, attrs
133 | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in
136 try Some (int_of_string (List.assoc "id" domain_attrs))
137 with Not_found -> None in
139 let rec loop = function
141 failwith (s_ "get_xml_desc returned no <name> node in XML")
142 | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
143 | Xml.Element ("name", _, _) :: _ ->
144 failwith (s_ "get_xml_desc returned strange <name> node")
145 | _ :: rest -> loop rest
147 let name = loop nodes in
153 | Xml.Element ("devices", _, devices) -> Some devices
156 List.concat devices in
158 let rec target_dev_of = function
160 | Xml.Element ("target", attrs, _) :: rest ->
161 (try Some (List.assoc "dev" attrs)
162 with Not_found -> target_dev_of rest)
163 | _ :: rest -> target_dev_of rest
166 let rec source_file_of = function
168 | Xml.Element ("source", attrs, _) :: rest ->
169 (try Some (List.assoc "file" attrs)
170 with Not_found -> source_file_of rest)
171 | _ :: rest -> source_file_of rest
174 let rec source_dev_of = function
176 | Xml.Element ("source", attrs, _) :: rest ->
177 (try Some (List.assoc "dev" attrs)
178 with Not_found -> source_dev_of rest)
179 | _ :: rest -> source_dev_of rest
185 | Xml.Element ("disk", attrs, children) ->
187 try Some (List.assoc "type" attrs)
188 with Not_found -> None in
190 try Some (List.assoc "device" attrs)
191 with Not_found -> None in
193 match source_file_of children with
194 | (Some _) as source -> source
195 | None -> source_dev_of children in
196 let target = target_dev_of children in
198 (* We only care about devices where we have
199 * source and target. Ignore CD-ROM devices.
201 (match source, target, device with
202 | _, _, Some "cdrom" -> None (* ignore *)
203 | Some source, Some target, Some device ->
204 (* Try to create a 'device' object for this
205 * device. If it fails, print a warning
206 * and ignore the device.
209 let dev = new block_device source in
211 d_type = typ; d_device = device;
212 d_source = source; d_target = target;
213 d_dev = dev; d_content = `Unknown
216 Unix_error (err, func, param) ->
217 eprintf "%s:%s: %s" func param (error_message err);
220 | _ -> None (* ignore anything else *)
226 { dom_name = name; dom_id = domid;
227 dom_disks = disks; dom_lv_filesystems = [] }
230 (* In test mode (-t option) the user can pass one or more
231 * block devices or filenames (containing partitions/filesystems/etc)
232 * which we use for testing virt-df itself. We create fake domains
238 dom_name = filename; dom_id = None;
241 d_type = Some "disk"; d_device = "disk";
242 d_source = filename; d_target = "hda";
243 d_dev = new block_device filename; d_content = `Unknown;
246 dom_lv_filesystems = []
251 (* HOF to map over disks. *)
252 let map_over_disks doms f =
254 fun ({ dom_disks = disks } as dom) ->
255 let disks = List.map f disks in
256 { dom with dom_disks = disks }
260 (* 'doms' is our list of domains and their guest block devices, and
261 * we've successfully opened each block device. Now probe them
262 * to find out what they contain.
264 let doms = map_over_disks doms (
265 fun ({ d_dev = dev } as disk) ->
266 (* See if it is partitioned first. *)
267 let parts = probe_for_partitions dev in
270 { disk with d_content = `Partitions parts }
272 (* Not partitioned. Does it contain a filesystem? *)
273 let fs = probe_for_filesystem dev in
276 { disk with d_content = `Filesystem fs }
278 (* Not partitioned, no filesystem, is it a PV? *)
279 let pv = probe_for_pv dev in
282 { disk with d_content = `PhysicalVolume lvm_name }
284 disk (* Spare/unknown. *)
287 (* Now we have either detected partitions or a filesystem on each
288 * physical device (or perhaps neither). See what is on those
291 let doms = map_over_disks doms (
293 | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
296 if p.part_status = Bootable || p.part_status = Nonbootable then (
297 let fs = probe_for_filesystem p.part_dev in
300 { p with part_content = `Filesystem fs }
303 let pv = probe_for_pv p.part_dev in
306 { p with part_content = `PhysicalVolume lvm_name }
308 p (* Spare/unknown. *)
311 let parts = { parts with parts = ps } in
312 { disk with d_content = `Partitions parts }
316 (* LVM filesystem detection
318 * For each domain, look for all disks/partitions which have been
319 * identified as PVs and pass those back to the respective LVM
320 * plugin for LV detection.
322 * (Note - a two-stage process because an LV can be spread over
323 * several PVs, so we have to detect all PVs belonging to a
326 (* First: LV detection. *)
327 let doms = List.map (
328 fun ({ dom_disks = disks } as dom) ->
329 (* Find all physical volumes, can be disks or partitions. *)
330 let pvs_on_disks = List.filter_map (
333 d_content = `PhysicalVolume lvm_name } -> Some (lvm_name, d_dev)
336 let pvs_on_partitions = List.map (
338 | { d_content = `Partitions { parts = parts } } ->
341 | { part_dev = part_dev;
342 part_content = `PhysicalVolume lvm_name } ->
343 Some (lvm_name, part_dev)
348 let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in
352 (* Second: filesystem on LV detection. *)
353 let doms = List.map (
355 (* Group the LVs by plug-in type. *)
356 let cmp ((a:string),_) ((b:string),_) = compare a b in
357 let lvs = List.sort ~cmp lvs in
358 let lvs = group_by lvs in
361 List.map (fun (lvm_name, devs) -> list_lvs lvm_name devs) lvs in
362 let lvs = List.concat lvs in
364 (* lvs is a list of potential LV devices. Now run them through the
365 * probes to see if any contain filesystems.
367 let filesystems = List.filter_map probe_for_filesystem lvs in
369 { dom with dom_lv_filesystems = filesystems }
372 (* Now print the results.
377 let total, used, avail =
378 match !inodes, !human with
379 | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available"
380 | false, true -> s_ "Size", s_ "Used", s_ "Available"
381 | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in
382 printf "%-20s %10s %10s %10s %s\n%!"
383 (s_ "Filesystem") total used avail (s_ "Type") in
385 let printable_size bytes =
386 if bytes < 1024L *^ 1024L then
387 sprintf "%Ld bytes" bytes
388 else if bytes < 1024L *^ 1024L *^ 1024L then
389 sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
391 sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
394 (* HOF to iterate over filesystems. *)
395 let iter_over_filesystems doms
396 (f : domain -> ?disk:disk -> ?part:(partition * int) -> filesystem ->
399 fun ({ dom_disks = disks; dom_lv_filesystems = filesystems } as dom) ->
400 (* Ordinary filesystems found on disks & partitions. *)
403 | ({ d_content = `Filesystem fs } as disk) ->
405 | ({ d_content = `Partitions partitions } as disk) ->
409 | ({ part_content = `Filesystem fs } as part) ->
410 f dom ~disk ~part:(part, i) fs
415 (* LV filesystems. *)
416 List.iter (fun fs -> f dom fs) filesystems
420 (* Print stats for each recognized filesystem. *)
421 let print_stats dom ?disk ?part fs =
422 (* Printable name is like "domain:hda" or "domain:hda1". *)
424 let dom_name = dom.dom_name in
427 | None -> "???" (* XXX keep LV dev around *)
428 | Some disk -> disk.d_target
432 dom_name ^ ":" ^ disk_name
434 dom_name ^ ":" ^ disk_name ^ string_of_int pnum in
435 printf "%-20s " name;
437 if fs.fs_is_swap then (
438 (* Swap partition. *)
441 (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name
444 (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name
446 (* Ordinary filesystem. *)
447 if not !inodes then ( (* Block display. *)
448 (* 'df' doesn't count the restricted blocks. *)
449 let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
450 let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
451 let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
453 if not !human then ( (* Display 1K blocks. *)
454 printf "%10Ld %10Ld %10Ld %s\n"
455 (blocks_total *^ fs.fs_block_size /^ 1024L)
456 (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L)
457 (blocks_avail *^ fs.fs_block_size /^ 1024L)
459 ) else ( (* Human-readable blocks. *)
460 printf "%10s %10s %10s %s\n"
461 (printable_size (blocks_total *^ fs.fs_block_size))
462 (printable_size (fs.fs_blocks_used *^ fs.fs_block_size))
463 (printable_size (blocks_avail *^ fs.fs_block_size))
466 ) else ( (* Inodes display. *)
467 printf "%10Ld %10Ld %10Ld %s\n"
468 fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail
473 iter_over_filesystems doms print_stats