1 (* 'df' command for virtual domains.
2 (C) Copyright 2007-2008 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 open Virt_df_gettext.Gettext
26 module C = Libvirt.Connect
27 module D = Libvirt.Domain
29 (* If set to true, then emit lots of debugging information. *)
32 (* Int32 infix operators for convenience. *)
33 let ( +* ) = Int32.add
34 let ( -* ) = Int32.sub
35 let ( ** ) = Int32.mul
36 let ( /* ) = Int32.div
38 (* Int64 infix operators for convenience. *)
39 let ( +^ ) = Int64.add
40 let ( -^ ) = Int64.sub
41 let ( *^ ) = Int64.mul
42 let ( /^ ) = Int64.div
44 (* State of command line arguments. *)
45 let uri = ref None (* Hypervisor/libvirt URI. *)
46 let inodes = ref false (* Display inodes. *)
47 let human = ref false (* Display human-readable. *)
48 let all = ref false (* Show all/active domains. *)
49 let test_files = ref [] (* Used for test mode only. *)
51 (*----------------------------------------------------------------------*)
52 (* The "domain/device model" that we currently understand looks
57 * \--- host partitions / disk image files
61 * +--> guest partitions (eg. using MBR)
63 * \-(1)->+--- filesystems (eg. ext3)
69 * (1) Filesystems and PVs may also appear directly on guest
72 * Partition schemes (eg. MBR) and filesystems register themselves
73 * with this main module and they are queried first to get an idea
74 * of the physical devices, partitions and filesystems potentially
75 * available to the guest.
77 * Volume management schemes (eg. LVM) register themselves here
78 * and are called later with "spare" physical devices and partitions
79 * to see if they contain LVM data. If this results in additional
80 * logical volumes then these are checked for filesystems.
82 * Swap space is considered to be a dumb filesystem for the purposes
86 (* A virtual (or physical!) device, encapsulating any translation
87 * that has to be done to access the device. eg. For partitions
88 * there is a simple offset, but for LVM you may need complicated
91 * We keep the underlying file descriptors open for the duration
92 * of the program. There aren't likely to be many of them, and
93 * the program is short-lived, and it's easier than trying to
94 * track which device is using what fd. As a result, there is no
95 * need for any close/deallocation function.
97 * Note the very rare use of OOP in OCaml!
99 class virtual device =
101 method virtual read : int64 -> int -> string
102 method virtual size : int64
103 method virtual name : string
105 (* Helper method to read a chunk of data into a bitstring. *)
106 method read_bitstring offset len =
107 let str = self#read offset len in
111 (* A concrete device which just direct-maps a file or /dev device. *)
112 class block_device filename =
113 let fd = openfile filename [ O_RDONLY ] 0 in
114 let size = (LargeFile.fstat fd).LargeFile.st_size in
117 method read offset len =
118 ignore (LargeFile.lseek fd offset SEEK_SET);
119 let str = String.make len '\000' in
123 method name = filename
126 (* A null device. Any attempt to read generates an error. *)
127 let null_device : device =
130 method read _ _ = assert false
135 (* Domains and candidate guest block devices. *)
138 dom_name : string; (* Domain name. *)
139 dom_id : int option; (* Domain ID (if running). *)
140 dom_disks : disk list; (* Domain disks. *)
143 (* From the XML ... *)
144 d_type : string option; (* The <disk type=...> *)
145 d_device : string; (* The <disk device=...> (eg "disk") *)
146 d_source : string; (* The <source file=... or dev> *)
147 d_target : string; (* The <target dev=...> (eg "hda") *)
149 (* About the device itself. *)
150 d_dev : device; (* Disk device. *)
151 d_content : disk_content; (* What's on it. *)
154 [ `Unknown (* Not probed or unknown. *)
155 | `Partitions of partitions (* Contains partitions. *)
156 | `Filesystem of filesystem (* Contains a filesystem directly. *)
157 | `PhysicalVolume of unit (* Contains an LVM PV. *)
163 parts_name : string; (* Name of partitioning scheme. *)
164 parts : partition list (* Partitions. *)
167 part_status : partition_status; (* Bootable, etc. *)
168 part_type : int; (* Partition filesystem type. *)
169 part_dev : device; (* Partition device. *)
170 part_content : partition_content; (* What's on it. *)
172 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
173 and partition_content =
174 [ `Unknown (* Not probed or unknown. *)
175 | `Filesystem of filesystem (* Filesystem. *)
176 | `PhysicalVolume of unit (* Contains an LVM PV. *)
179 (* Filesystems (also swap devices). *)
181 fs_name : string; (* Name of filesystem. *)
182 fs_block_size : int64; (* Block size (bytes). *)
183 fs_blocks_total : int64; (* Total blocks. *)
184 fs_is_swap : bool; (* If swap, following not valid. *)
185 fs_blocks_reserved : int64; (* Blocks reserved for super-user. *)
186 fs_blocks_avail : int64; (* Blocks free (available). *)
187 fs_blocks_used : int64; (* Blocks in use. *)
188 fs_inodes_total : int64; (* Total inodes. *)
189 fs_inodes_reserved : int64; (* Inodes reserved for super-user. *)
190 fs_inodes_avail : int64; (* Inodes free (available). *)
191 fs_inodes_used : int64; (* Inodes in use. *)
194 (* Convert partition, filesystem types to printable strings for debugging. *)
195 let string_of_partition
196 { part_status = status; part_type = typ; part_dev = dev } =
197 sprintf "%s: %s partition type %d"
200 | Bootable -> "bootable"
201 | Nonbootable -> "nonbootable"
202 | Malformed -> "malformed"
203 | NullEntry -> "empty")
206 let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
207 if not swap then name
208 else name ^ " [swap]"
210 (* Register a partition scheme. *)
211 let partition_types = ref []
212 let partition_type_register (parts_name : string) probe_fn =
213 partition_types := (parts_name, probe_fn) :: !partition_types
215 (* Probe a device for partitions. Returns [Some parts] or [None]. *)
216 let probe_for_partitions dev =
217 if debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
218 let rec loop = function
220 | (parts_name, probe_fn) :: rest ->
221 try Some (probe_fn dev)
222 with Not_found -> loop rest
224 let r = loop !partition_types in
227 | None -> eprintf "no partitions found on %s\n%!" dev#name
228 | Some { parts_name = name; parts = parts } ->
229 eprintf "found %d %s partitions on %s:\n"
230 (List.length parts) name dev#name;
231 List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
235 (* Register a filesystem type (or swap). *)
236 let filesystem_types = ref []
237 let filesystem_type_register (fs_name : string) probe_fn =
238 filesystem_types := (fs_name, probe_fn) :: !filesystem_types
240 (* Probe a device for filesystems. Returns [Some fs] or [None]. *)
241 let probe_for_filesystems dev =
242 if debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
243 let rec loop = function
245 | (fs_name, probe_fn) :: rest ->
246 try Some (probe_fn dev)
247 with Not_found -> loop rest
249 let r = loop !filesystem_types in
252 | None -> eprintf "no filesystem found on %s\n%!" dev#name
254 eprintf "found a filesystem on %s:\n" dev#name;
255 eprintf "\t%s\n%!" (string_of_filesystem fs)
259 (* Register a volume management type. *)
261 let lvm_types = ref []
262 let lvm_type_register (lvm_name : string) probe_fn =
263 lvm_types := (lvm_name, probe_fn) :: !lvm_types
266 (*----------------------------------------------------------------------*)
269 (* Command line argument parsing. *)
270 let set_uri = function "" -> uri := None | u -> uri := Some u in
273 printf "virt-df %s\n" (Libvirt_version.version);
275 let major, minor, release =
276 let v, _ = Libvirt.get_version () in
277 v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
278 printf "libvirt %d.%d.%d\n" major minor release;
282 let test_mode filename =
283 test_files := filename :: !test_files
286 let argspec = Arg.align [
288 " " ^ s_ "Show all domains (default: only active domains)";
289 "--all", Arg.Set all,
290 " " ^ s_ "Show all domains (default: only active domains)";
291 "-c", Arg.String set_uri,
292 "uri " ^ s_ "Connect to URI (default: Xen)";
293 "--connect", Arg.String set_uri,
294 "uri " ^ s_ "Connect to URI (default: Xen)";
296 " " ^ s_ "Print sizes in human-readable format";
297 "--human-readable", Arg.Set human,
298 " " ^ s_ "Print sizes in human-readable format";
299 "-i", Arg.Set inodes,
300 " " ^ s_ "Show inodes instead of blocks";
301 "--inodes", Arg.Set inodes,
302 " " ^ s_ "Show inodes instead of blocks";
303 "-t", Arg.String test_mode,
304 "dev" ^ s_ "(Test mode) Display contents of block device or file";
305 "--version", Arg.Unit version,
306 " " ^ s_ "Display version and exit";
310 raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
311 let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests
318 Arg.parse argspec anon_fun usage_msg;
320 let doms : domain list =
321 if !test_files = [] then (
323 (* Connect to the hypervisor. *)
326 try C.connect_readonly ?name ()
328 Libvirt.Virterror err ->
329 prerr_endline (Libvirt.Virterror.to_string err);
330 (* If non-root and no explicit connection URI, print a warning. *)
331 if geteuid () <> 0 && name = None then (
332 print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
336 (* Get the list of active & inactive domains. *)
338 let nr_active_doms = C.num_of_domains conn in
340 Array.to_list (C.list_domains conn nr_active_doms) in
342 List.map (D.lookup_by_id conn) active_doms in
346 let nr_inactive_doms = C.num_of_defined_domains conn in
348 Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
350 List.map (D.lookup_by_name conn) inactive_doms in
351 active_doms @ inactive_doms
355 let xmls = List.map D.get_xml_desc doms in
358 let xmls = List.map Xml.parse_string xmls in
360 (* Return just the XML documents - everything else will be closed
361 * and freed including the connection to the hypervisor.
365 (* Grr.. Need to use a library which has XPATH support (or cduce). *)
368 let nodes, domain_attrs =
370 | Xml.Element ("domain", attrs, children) -> children, attrs
371 | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in
374 try Some (int_of_string (List.assoc "id" domain_attrs))
375 with Not_found -> None in
377 let rec loop = function
379 failwith (s_ "get_xml_desc returned no <name> node in XML")
380 | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
381 | Xml.Element ("name", _, _) :: _ ->
382 failwith (s_ "get_xml_desc returned strange <name> node")
383 | _ :: rest -> loop rest
385 let name = loop nodes in
391 | Xml.Element ("devices", _, devices) -> Some devices
394 List.concat devices in
396 let rec target_dev_of = function
398 | Xml.Element ("target", attrs, _) :: rest ->
399 (try Some (List.assoc "dev" attrs)
400 with Not_found -> target_dev_of rest)
401 | _ :: rest -> target_dev_of rest
404 let rec source_file_of = function
406 | Xml.Element ("source", attrs, _) :: rest ->
407 (try Some (List.assoc "file" attrs)
408 with Not_found -> source_file_of rest)
409 | _ :: rest -> source_file_of rest
412 let rec source_dev_of = function
414 | Xml.Element ("source", attrs, _) :: rest ->
415 (try Some (List.assoc "dev" attrs)
416 with Not_found -> source_dev_of rest)
417 | _ :: rest -> source_dev_of rest
423 | Xml.Element ("disk", attrs, children) ->
425 try Some (List.assoc "type" attrs)
426 with Not_found -> None in
428 try Some (List.assoc "device" attrs)
429 with Not_found -> None in
431 match source_file_of children with
432 | (Some _) as source -> source
433 | None -> source_dev_of children in
434 let target = target_dev_of children in
436 (* We only care about devices where we have
437 * source and target. Ignore CD-ROM devices.
439 (match source, target, device with
440 | _, _, Some "cdrom" -> None (* ignore *)
441 | Some source, Some target, Some device ->
442 (* Try to create a 'device' object for this
443 * device. If it fails, print a warning
444 * and ignore the device.
447 let dev = new block_device source in
449 d_type = typ; d_device = device;
450 d_source = source; d_target = target;
451 d_dev = dev; d_content = `Unknown
454 Unix_error (err, func, param) ->
455 eprintf "%s:%s: %s" func param (error_message err);
458 | _ -> None (* ignore anything else *)
464 { dom_name = name; dom_id = domid; dom_disks = disks }
467 (* In test mode (-t option) the user can pass one or more
468 * block devices or filenames (containing partitions/filesystems/etc)
469 * which we use for testing virt-df itself. We create fake domains
475 dom_name = filename; dom_id = None;
478 d_type = Some "disk"; d_device = "disk";
479 d_source = filename; d_target = "hda";
480 d_dev = new block_device filename; d_content = `Unknown;
487 (* HOF to map over disks. *)
488 let map_over_disks doms f =
490 fun ({ dom_disks = disks } as dom) ->
491 let disks = List.map f disks in
492 { dom with dom_disks = disks }
496 (* 'doms' is our list of domains and their guest block devices, and
497 * we've successfully opened each block device. Now probe them
498 * to find out what they contain.
500 let doms = map_over_disks doms (
501 fun ({ d_dev = dev } as disk) ->
502 (* See if it is partitioned first. *)
503 let parts = probe_for_partitions dev in
506 { disk with d_content = `Partitions parts }
508 (* Not partitioned. Does it contain a filesystem? *)
509 let fs = probe_for_filesystems dev in
512 { disk with d_content = `Filesystem fs }
514 (* Not partitioned, no filesystem, so it's spare. *)
518 (* Now we have either detected partitions or a filesystem on each
519 * physical device (or perhaps neither). See what is on those
522 let doms = map_over_disks doms (
524 | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
527 if p.part_status = Bootable || p.part_status = Nonbootable then (
528 let fs = probe_for_filesystems p.part_dev in
531 { p with part_content = `Filesystem fs }
536 let parts = { parts with parts = ps } in
537 { disk with d_content = `Partitions parts }
541 (* XXX LVM stuff here. *)
545 (* Print the title. *)
547 let total, used, avail =
548 match !inodes, !human with
549 | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available"
550 | false, true -> s_ "Size", s_ "Used", s_ "Available"
551 | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in
552 printf "%-20s %10s %10s %10s %s\n%!"
553 (s_ "Filesystem") total used avail (s_ "Type") in
555 let printable_size bytes =
556 if bytes < 1024L *^ 1024L then
557 sprintf "%Ld bytes" bytes
558 else if bytes < 1024L *^ 1024L *^ 1024L then
559 sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
561 sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
564 (* HOF to iterate over filesystems. *)
565 let iter_over_filesystems doms f =
567 fun ({ dom_disks = disks } as dom) ->
570 | ({ d_content = `Filesystem fs } as disk) ->
572 | ({ d_content = `Partitions partitions } as disk) ->
576 | ({ part_content = `Filesystem fs } as part) ->
577 f dom disk (Some (part, i)) fs
585 (* Print stats for each recognized filesystem. *)
586 let print_stats dom disk part fs =
587 (* Printable name is like "domain:hda" or "domain:hda1". *)
589 let dom_name = dom.dom_name in
590 let d_target = disk.d_target in
593 dom_name ^ ":" ^ d_target
595 dom_name ^ ":" ^ d_target ^ string_of_int pnum in
596 printf "%-20s " name;
598 if fs.fs_is_swap then (
599 (* Swap partition. *)
602 (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name
605 (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name
607 (* Ordinary filesystem. *)
608 if not !inodes then ( (* Block display. *)
609 (* 'df' doesn't count the restricted blocks. *)
610 let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
611 let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
612 let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
614 if not !human then ( (* Display 1K blocks. *)
615 printf "%10Ld %10Ld %10Ld %s\n"
616 (blocks_total *^ fs.fs_block_size /^ 1024L)
617 (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L)
618 (blocks_avail *^ fs.fs_block_size /^ 1024L)
620 ) else ( (* Human-readable blocks. *)
621 printf "%10s %10s %10s %s\n"
622 (printable_size (blocks_total *^ fs.fs_block_size))
623 (printable_size (fs.fs_blocks_used *^ fs.fs_block_size))
624 (printable_size (blocks_avail *^ fs.fs_block_size))
627 ) else ( (* Inodes display. *)
628 printf "%10Ld %10Ld %10Ld %s\n"
629 fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail
634 iter_over_filesystems doms print_stats
637 (* Probe a single partition, which we assume contains either a
638 * filesystem or is a PV.
639 * - target will be something like "hda" or "hda1"
640 * - part_type will be the partition type if known, or None
641 * - fd is a file descriptor opened on the device
642 * - start & size are where we think the start and size of the
643 * partition is within the file descriptor (in SECTORS)
645 and probe_partition target part_type fd start size =
648 ProbeFailed (s_ "detection of unpartitioned devices not yet supported")
650 ProbeIgnore (* Extended partition - ignore it. *)
653 let probe_fn = Hashtbl.find filesystems part_type in
654 probe_fn target part_type fd start size
658 (sprintf (f_ "unsupported partition type %02x") part_type)