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.
23 module C = Libvirt.Connect
24 module D = Libvirt.Domain
26 open Virt_df_gettext.Gettext
30 (* Command line argument parsing. *)
31 let set_uri = function "" -> uri := None | u -> uri := Some u in
34 printf "virt-df %s\n" (Libvirt_version.version);
36 let major, minor, release =
37 let v, _ = Libvirt.get_version () in
38 v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
39 printf "libvirt %d.%d.%d\n" major minor release;
43 let test_mode filename = test_files := filename :: !test_files in
45 let argspec = Arg.align [
47 " " ^ s_ "Show all domains (default: only active domains)";
49 " " ^ s_ "Show all domains (default: only active domains)";
50 "-c", Arg.String set_uri,
51 "uri " ^ s_ "Connect to URI (default: Xen)";
52 "--connect", Arg.String set_uri,
53 "uri " ^ s_ "Connect to URI (default: Xen)";
54 "--csv", Arg.Set csv_mode,
55 " " ^ s_ "Write results in CSV format";
56 "--debug", Arg.Set debug,
57 " " ^ s_ "Debug mode (default: false)";
59 " " ^ s_ "Print sizes in human-readable format";
60 "--human-readable", Arg.Set human,
61 " " ^ s_ "Print sizes in human-readable format";
63 " " ^ s_ "Show inodes instead of blocks";
64 "--inodes", Arg.Set inodes,
65 " " ^ s_ "Show inodes instead of blocks";
66 "-t", Arg.String test_mode,
67 "dev " ^ s_ "(Test mode) Display contents of block device or file";
68 "--version", Arg.Unit version,
69 " " ^ s_ "Display version and exit";
73 raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
74 let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests
81 Arg.parse argspec anon_fun usage_msg;
83 (* Set up CSV support. *)
86 fun _ -> assert false (* Should never happen. *)
90 prerr_endline (s_ "CSV is not supported in this build of virt-df");
96 let doms : domain list =
97 if !test_files = [] then (
99 (* Connect to the hypervisor. *)
102 try C.connect_readonly ?name ()
104 Libvirt.Virterror err ->
105 prerr_endline (Libvirt.Virterror.to_string err);
106 (* If non-root and no explicit connection URI, print a warning. *)
107 if Unix.geteuid () <> 0 && name = None then (
108 print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
112 (* Get the list of active & inactive domains. *)
114 let nr_active_doms = C.num_of_domains conn in
116 Array.to_list (C.list_domains conn nr_active_doms) in
118 List.map (D.lookup_by_id conn) active_doms in
122 let nr_inactive_doms = C.num_of_defined_domains conn in
124 Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
126 List.map (D.lookup_by_name conn) inactive_doms in
127 active_doms @ inactive_doms
131 let xmls = List.map D.get_xml_desc doms in
134 let xmls = List.map Xml.parse_string xmls in
136 (* Return just the XML documents - everything else will be closed
137 * and freed including the connection to the hypervisor.
141 (* Grr.. Need to use a library which has XPATH support (or cduce). *)
144 let nodes, domain_attrs =
146 | Xml.Element ("domain", attrs, children) -> children, attrs
147 | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in
150 try Some (int_of_string (List.assoc "id" domain_attrs))
151 with Not_found -> None in
153 let rec loop = function
155 failwith (s_ "get_xml_desc returned no <name> node in XML")
156 | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
157 | Xml.Element ("name", _, _) :: _ ->
158 failwith (s_ "get_xml_desc returned strange <name> node")
159 | _ :: rest -> loop rest
161 let name = loop nodes in
167 | Xml.Element ("devices", _, devices) -> Some devices
170 List.concat devices in
172 let rec target_dev_of = function
174 | Xml.Element ("target", attrs, _) :: rest ->
175 (try Some (List.assoc "dev" attrs)
176 with Not_found -> target_dev_of rest)
177 | _ :: rest -> target_dev_of rest
180 let rec source_file_of = function
182 | Xml.Element ("source", attrs, _) :: rest ->
183 (try Some (List.assoc "file" attrs)
184 with Not_found -> source_file_of rest)
185 | _ :: rest -> source_file_of rest
188 let rec source_dev_of = function
190 | Xml.Element ("source", attrs, _) :: rest ->
191 (try Some (List.assoc "dev" attrs)
192 with Not_found -> source_dev_of rest)
193 | _ :: rest -> source_dev_of rest
199 | Xml.Element ("disk", attrs, children) ->
201 try Some (List.assoc "type" attrs)
202 with Not_found -> None in
204 try Some (List.assoc "device" attrs)
205 with Not_found -> None in
207 match source_file_of children with
208 | (Some _) as source -> source
209 | None -> source_dev_of children in
210 let target = target_dev_of children in
212 (* We only care about devices where we have
213 * source and target. Ignore CD-ROM devices.
215 (match source, target, device with
216 | _, _, Some "cdrom" -> None (* ignore *)
217 | Some source, Some target, Some device ->
218 (* Try to create a 'device' object for this
219 * device. If it fails, print a warning
220 * and ignore the device.
223 let dev = new block_device source in
225 d_type = typ; d_device = device;
226 d_source = source; d_target = target;
227 d_dev = dev; d_content = `Unknown
230 Unix.Unix_error (err, func, param) ->
231 eprintf "%s:%s: %s" func param
232 (Unix.error_message err);
235 | _ -> None (* ignore anything else *)
241 { dom_name = name; dom_id = domid;
242 dom_disks = disks; dom_lv_filesystems = [] }
245 (* In test mode (-t option) the user can pass one or more
246 * block devices or filenames (containing partitions/filesystems/etc)
247 * which we use for testing virt-df itself. We create fake domains
253 dom_name = filename; dom_id = None;
256 d_type = Some "disk"; d_device = "disk";
257 d_source = filename; d_target = "hda";
258 d_dev = new block_device filename; d_content = `Unknown;
261 dom_lv_filesystems = []
266 (* HOF to map over disks. *)
267 let map_over_disks doms f =
269 fun ({ dom_disks = disks } as dom) ->
270 let disks = List.map f disks in
271 { dom with dom_disks = disks }
275 (* 'doms' is our list of domains and their guest block devices, and
276 * we've successfully opened each block device. Now probe them
277 * to find out what they contain.
279 let doms = map_over_disks doms (
280 fun ({ d_dev = dev } as disk) ->
281 (* See if it is partitioned first. *)
282 let parts = probe_for_partitions dev in
285 { disk with d_content = `Partitions parts }
287 (* Not partitioned. Does it contain a filesystem? *)
288 let fs = probe_for_filesystem dev in
291 { disk with d_content = `Filesystem fs }
293 (* Not partitioned, no filesystem, is it a PV? *)
294 let pv = probe_for_pv dev in
297 { disk with d_content = `PhysicalVolume lvm_name }
299 disk (* Spare/unknown. *)
302 (* Now we have either detected partitions or a filesystem on each
303 * physical device (or perhaps neither). See what is on those
306 let doms = map_over_disks doms (
308 | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
311 if p.part_status = Bootable || p.part_status = Nonbootable then (
312 let fs = probe_for_filesystem p.part_dev in
315 { p with part_content = `Filesystem fs }
318 let pv = probe_for_pv p.part_dev in
321 { p with part_content = `PhysicalVolume lvm_name }
323 p (* Spare/unknown. *)
326 let parts = { parts with parts = ps } in
327 { disk with d_content = `Partitions parts }
331 (* LVM filesystem detection
333 * For each domain, look for all disks/partitions which have been
334 * identified as PVs and pass those back to the respective LVM
335 * plugin for LV detection.
337 * (Note - a two-stage process because an LV can be spread over
338 * several PVs, so we have to detect all PVs belonging to a
341 * XXX To deal with RAID (ie. md devices) we will need to loop
342 * around here because RAID is like LVM except that they normally
343 * present as block devices which can be used by LVM.
345 (* First: LV detection. *)
346 let doms = List.map (
347 fun ({ dom_disks = disks } as dom) ->
348 (* Find all physical volumes, can be disks or partitions. *)
349 let pvs_on_disks = List.filter_map (
352 d_content = `PhysicalVolume pv } -> Some (pv, d_dev)
355 let pvs_on_partitions = List.map (
357 | { d_content = `Partitions { parts = parts } } ->
360 | { part_dev = part_dev;
361 part_content = `PhysicalVolume pv } ->
367 let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in
371 (* Second: filesystem on LV detection. *)
372 let doms = List.map (
374 (* Group the LVs by plug-in type. *)
375 let cmp (a,_) (b,_) = compare a b in
376 let lvs = List.sort ~cmp lvs in
377 let lvs = group_by lvs in
380 List.map (fun (pv, devs) -> list_lvs pv.lvm_plugin_id devs) lvs in
381 let lvs = List.concat lvs in
383 (* lvs is a list of potential LV devices. Now run them through the
384 * probes to see if any contain filesystems.
388 fun ({ lv_dev = dev } as lv) ->
389 match probe_for_filesystem dev with
390 | Some fs -> Some (lv, fs)
394 { dom with dom_lv_filesystems = filesystems }
397 (*----------------------------------------------------------------------*)
398 (* Now print the results. *)
400 (* Print the title. *)
402 let total, used, avail =
403 match !inodes, !human with
404 | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available"
405 | false, true -> s_ "Size", s_ "Used", s_ "Available"
406 | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in
407 if not !csv_mode then
408 printf "%-32s %10s %10s %10s %s\n%!"
409 (s_ "Filesystem") total used avail (s_ "Type")
411 csv_write [ "Filesystem"; total; used; avail; "Type" ] in
413 let printable_size bytes =
414 if bytes < 1024L *^ 1024L then
415 sprintf "%Ld bytes" bytes
416 else if bytes < 1024L *^ 1024L *^ 1024L then
417 sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
419 sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
422 (* HOF to iterate over filesystems. *)
423 let iter_over_filesystems doms
424 (f : domain -> ?disk:disk -> ?partno:int -> device -> filesystem ->
427 fun ({ dom_disks = disks; dom_lv_filesystems = filesystems } as dom) ->
428 (* Ordinary filesystems found on disks & partitions. *)
431 | ({ d_content = `Filesystem fs; d_dev = dev } as disk) ->
433 | ({ d_content = `Partitions partitions } as disk) ->
437 | { part_content = `Filesystem fs; part_dev = dev } ->
438 f dom ~disk ~partno:(i+1) dev fs
443 (* LV filesystems. *)
444 List.iter (fun ({lv_dev = dev}, fs) -> f dom dev fs) filesystems
448 (* Printable name is like "domain:hda" or "domain:hda1". *)
449 let printable_name dom ?disk ?partno dev =
450 let dom_name = dom.dom_name in
451 (* Get the disk name (eg. "hda") from the domain XML, if
452 * we have it, otherwise use the device name (eg. for LVM).
457 | Some disk -> disk.d_target
461 dom_name ^ ":" ^ disk_name
463 dom_name ^ ":" ^ disk_name ^ string_of_int partno
466 (* Print stats for each recognized filesystem. *)
467 let print_stats dom ?disk ?partno dev fs =
468 let name = printable_name dom ?disk ?partno dev in
469 printf "%-32s " name;
471 if fs.fs_is_swap then (
472 (* Swap partition. *)
475 (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name
478 (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name
480 (* Ordinary filesystem. *)
481 if not !inodes then ( (* Block display. *)
482 (* 'df' doesn't count the restricted blocks. *)
483 let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
484 let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
485 let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
487 if not !human then ( (* Display 1K blocks. *)
488 printf "%10Ld %10Ld %10Ld %s\n"
489 (blocks_total *^ fs.fs_block_size /^ 1024L)
490 (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L)
491 (blocks_avail *^ fs.fs_block_size /^ 1024L)
493 ) else ( (* Human-readable blocks. *)
494 printf "%10s %10s %10s %s\n"
495 (printable_size (blocks_total *^ fs.fs_block_size))
496 (printable_size (fs.fs_blocks_used *^ fs.fs_block_size))
497 (printable_size (blocks_avail *^ fs.fs_block_size))
500 ) else ( (* Inodes display. *)
501 printf "%10Ld %10Ld %10Ld %s\n"
502 fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail
508 (* Alternate version of print_stats which writes to a CSV file.
509 * We ignore the human-readable option because we assume that
510 * the data will be post-processed by something.
512 let print_stats_csv dom ?disk ?partno dev fs =
513 let name = printable_name dom ?disk ?partno dev in
516 if fs.fs_is_swap then
517 (* Swap partition. *)
518 [ Int64.to_string (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L);
521 (* Ordinary filesystem. *)
522 if not !inodes then ( (* Block display. *)
523 (* 'df' doesn't count the restricted blocks. *)
524 let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
525 let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
526 let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
528 [ Int64.to_string (blocks_total *^ fs.fs_block_size /^ 1024L);
529 Int64.to_string (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L);
530 Int64.to_string (blocks_avail *^ fs.fs_block_size /^ 1024L) ]
531 ) else ( (* Inodes display. *)
532 [ Int64.to_string fs.fs_inodes_total;
533 Int64.to_string fs.fs_inodes_used;
534 Int64.to_string fs.fs_inodes_avail ]
538 let row = name :: row @ [fs.fs_name] in
542 iter_over_filesystems doms
543 (if not !csv_mode then print_stats else print_stats_csv)