1 (* 'df' command for virtual domains.
10 module C = Libvirt.Connect
11 module D = Libvirt.Domain
12 module N = Libvirt.Network
14 (* Int64 operators for convenience.
15 * For sanity we do all int operations as int64's.
19 let ( *^ ) = Int64.mul
23 let inodes = ref false
26 (* Maximum number of extended partitions possible. *)
27 let max_extended_partitions = 100
29 let sector_size = 512L
31 (* Parse out the device XML to get the names of disks. *)
33 dom_name : string; (* Domain name. *)
34 dom_id : int option; (* Domain ID (if running). *)
35 dom_disks : disk list; (* Domain disks. *)
38 d_type : string option; (* The <disk type=...> *)
39 d_device : string option; (* The <disk device=...> *)
40 d_source : string option; (* The <source file=... or dev> *)
41 d_target : string option; (* The <target dev=...> *)
45 part_status : partition_status; (* Bootable, etc. *)
46 part_type : int; (* Partition type. *)
47 part_lba_start : int64; (* LBA start sector. *)
48 part_len : int64; (* Length in sectors. *)
50 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
52 type filesystem_stats = {
54 fs_block_size : int64; (* Block size (bytes). *)
55 fs_blocks_total : int64; (* Total blocks. *)
56 fs_blocks_reserved : int64; (* Blocks reserved for super-user. *)
57 fs_blocks_avail : int64; (* Blocks free (available). *)
58 fs_blocks_used : int64; (* Blocks in use. *)
59 fs_inodes_total : int64; (* Total inodes. *)
60 fs_inodes_reserved : int64; (* Inodes reserved for super-user. *)
61 fs_inodes_avail : int64; (* Inodes free (available). *)
62 fs_inodes_used : int64; (* Inodes in use. *)
66 swap_block_size : int64; (* Block size (bytes). *)
67 swap_blocks_total : int64; (* Total blocks. *)
69 and fs_probe_t = (* Return type of the probe_partition.*)
70 | Filesystem of filesystem_stats
72 | ProbeFailed of string (* Probe failed for some reason. *)
73 | ProbeIgnore (* This filesystem should be ignored. *)
75 (* Register a filesystem type. *)
76 let filesystems = Hashtbl.create 13
77 let fs_register part_types probe_fn =
79 (fun part_type -> Hashtbl.replace filesystems part_type probe_fn)
82 (* Probe the devices and display.
83 * - dom_name is the domain name
84 * - target will be something like "hda"
85 * - source will be the name of a file or disk partition on the local machine
87 let rec probe_device dom_name target source =
88 let fd = openfile source [ O_RDONLY ] 0 in
89 let size = (LargeFile.fstat fd).LargeFile.st_size in
90 let size = size /^ sector_size in (* Size in sectors. *)
92 print_device dom_name target source size;
94 let partitions = probe_mbr fd in
96 if partitions <> [] then (
100 if part.part_status = Bootable ||
101 part.part_status = Nonbootable then (
103 let target = target ^ string_of_int pnum in
105 probe_partition target (Some part.part_type)
106 fd part.part_lba_start part.part_len)
111 let stats = List.filter_map (fun x -> x) stats in
113 ) else (* Not an MBR, assume it's a single partition. *)
114 print_stats [target, probe_partition target None fd 0L size];
118 (* Probe the master boot record (if it is one) and read the partitions.
119 * Returns [] if this is not an MBR.
120 * http://en.wikipedia.org/wiki/Master_boot_record
123 lseek fd 510 SEEK_SET;
124 let str = String.create 2 in
125 if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then
128 (* Read the partition table. *)
129 lseek fd 446 SEEK_SET;
130 let str = String.create 64 in
131 if read fd str 0 64 <> 64 then
132 failwith "error reading partition table"
134 (* Extract partitions from the data. *)
135 let primaries = List.map (get_partition str) [ 0; 16; 32; 48 ] in
136 (* XXX validate partition extents compared to disk. *)
137 (* Read extended partition data. *)
138 let extendeds = List.map (
140 | { part_type = 0x05 } as part ->
141 probe_extended_partition
142 max_extended_partitions fd part part.part_lba_start
145 let extendeds = List.concat extendeds in
146 primaries @ extendeds
150 (* Probe an extended partition. *)
151 and probe_extended_partition max fd epart sect =
153 (* Offset of the first EBR. *)
154 let ebr_offs = sect *^ sector_size in
156 LargeFile.lseek fd (ebr_offs +^ 510L) SEEK_SET;
157 let str = String.create 2 in
158 if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then
161 (* Read the extended partition table entries (just 2 of them). *)
162 LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET;
163 let str = String.create 32 in
164 if read fd str 0 32 <> 32 then
165 failwith "error reading extended partition"
167 (* Extract partitions from the data. *)
169 match List.map (get_partition str) [ 0; 16 ] with
171 | _ -> failwith "probe_extended_partition: internal error" in
172 (* First partition entry has offset to the start of this partition. *)
173 let part1 = { part1 with
174 part_lba_start = sect +^ part1.part_lba_start } in
175 (* Second partition entry is zeroes if end of list, otherwise points
176 * to the next partition.
178 if part2.part_status = NullEntry then
181 part1 :: probe_extended_partition
182 (max-1) fd epart (sect +^ part2.part_lba_start)
188 (* Get the partition data from str.[offs] - str.[offs+15] *)
189 and get_partition str offs =
190 let part_type = Char.code str.[offs+4] in
191 let part_lba_start = read_int32_le str (offs+8) in
192 let part_len = read_int32_le str (offs+12) in
195 if part_type = 0 && part_lba_start = 0L && part_len = 0L then
198 let part_status = Char.code str.[offs] in
199 match part_status with
200 | 0x80 -> Bootable | 0 -> Nonbootable | _ -> Malformed
203 { part_status = part_status;
204 part_type = part_type;
205 part_lba_start = part_lba_start;
206 part_len = part_len }
208 (* Probe a single partition, which we assume contains either a
209 * filesystem or is a PV.
210 * - target will be something like "hda" or "hda1"
211 * - part_type will be the partition type if known, or None
212 * - fd is a file descriptor opened on the device
213 * - start & size are where we think the start and size of the
214 * partition is within the file descriptor (in SECTORS)
216 and probe_partition target part_type fd start size =
219 ProbeFailed "detection of unpartitioned devices not yet supported"
221 ProbeIgnore (* Extended partition - ignore it. *)
224 let probe_fn = Hashtbl.find filesystems part_type in
225 probe_fn target part_type fd start size
229 (sprintf "unsupported partition type %02x" part_type)
231 and print_stats statss =
234 (* Swap partition. *)
235 | (target, Swap { swap_name = swap_name;
236 swap_block_size = block_size;
237 swap_blocks_total = blocks_total }) ->
239 printf "\t%s %Ld %s\n"
240 target (block_size *^ blocks_total /^ 1024L) swap_name
242 printf "\t%s %s %s\n"
243 target (printable_size (block_size *^ blocks_total)) swap_name
245 (* Ordinary filesystem. *)
246 | (target, Filesystem stats) ->
247 printf "\t%s " target;
249 if not !inodes then ( (* Block display. *)
250 (* 'df' doesn't count the restricted blocks. *)
252 stats.fs_blocks_total -^ stats.fs_blocks_reserved in
254 stats.fs_blocks_avail -^ stats.fs_blocks_reserved in
256 if blocks_avail < 0L then 0L else blocks_avail in
258 if not !human then ( (* Display 1K blocks. *)
259 printf "%Ld %Ld %Ld %s\n"
260 (blocks_total *^ stats.fs_block_size /^ 1024L)
261 (stats.fs_blocks_used *^ stats.fs_block_size /^ 1024L)
262 (blocks_avail *^ stats.fs_block_size /^ 1024L)
264 ) else ( (* Human-readable blocks. *)
265 printf "%s %s %s %s\n"
266 (printable_size (blocks_total *^ stats.fs_block_size))
267 (printable_size (stats.fs_blocks_used *^ stats.fs_block_size))
268 (printable_size (blocks_avail *^ stats.fs_block_size))
271 ) else ( (* Inodes display. *)
272 printf "%Ld %Ld %Ld %s\n"
273 stats.fs_inodes_total stats.fs_inodes_used stats.fs_inodes_avail
277 (* Unsupported filesystem or other failure. *)
278 | (target, ProbeFailed reason) ->
279 printf "\t%s %s\n" target reason
281 | (_, ProbeIgnore) -> ()
284 (* Target is something like "hda" and size is the size in sectors. *)
285 and print_device dom_name target source size =
286 printf "%s /dev/%s (%s) %s\n"
287 dom_name target (printable_size (size *^ sector_size)) source
289 and printable_size bytes =
290 if bytes < 1024L *^ 1024L then
291 sprintf "%Ld bytes" bytes
292 else if bytes < 1024L *^ 1024L *^ 1024L then
293 sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
295 sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
297 and read_int32_le str offs =
298 Int64.of_int (Char.code str.[offs]) +^
299 256L *^ Int64.of_int (Char.code str.[offs+1]) +^
300 65536L *^ Int64.of_int (Char.code str.[offs+2]) +^
301 16777216L *^ Int64.of_int (Char.code str.[offs+3])
303 and read_int16_le str offs =
304 Int64.of_int (Char.code str.[offs]) +^
305 256L *^ Int64.of_int (Char.code str.[offs+1])
308 (* Command line argument parsing. *)
309 let set_uri = function "" -> uri := None | u -> uri := Some u in
311 let argspec = Arg.align [
312 "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)";
313 "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)";
314 "-h", Arg.Set human, " Print sizes in human-readable format";
315 "--human-readable", Arg.Set human, " Print sizes in human-readable format";
316 "-i", Arg.Set inodes, " Show inodes instead of blocks";
317 "--inodes", Arg.Set inodes, " Show inodes instead of blocks";
320 let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in
321 let usage_msg = "virt-df : like 'df', shows disk space used in guests
328 Arg.parse argspec anon_fun usage_msg;
331 (* Connect to the hypervisor. *)
334 try C.connect_readonly ?name ()
336 Libvirt.Virterror err ->
337 prerr_endline (Libvirt.Virterror.to_string err);
338 (* If non-root and no explicit connection URI, print a warning. *)
339 if geteuid () <> 0 && name = None then (
340 print_endline "NB: If you want to monitor a local Xen hypervisor, you usually need to be root";
344 (* Get the list of active & inactive domains. *)
346 let nr_active_doms = C.num_of_domains conn in
347 let active_doms = Array.to_list (C.list_domains conn nr_active_doms) in
348 let active_doms = List.map (D.lookup_by_id conn) active_doms in
349 let nr_inactive_doms = C.num_of_defined_domains conn in
351 Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
352 let inactive_doms = List.map (D.lookup_by_name conn) inactive_doms in
353 active_doms @ inactive_doms in
356 let xmls = List.map D.get_xml_desc doms in
359 let xmls = List.map Xml.parse_string xmls in
361 (* Return just the XML documents - everything else will be closed
362 * and freed including the connection to the hypervisor.
366 let doms : domain list =
367 (* Grr.. Need to use a library which has XPATH support (or cduce). *)
370 let nodes, domain_attrs =
372 | Xml.Element ("domain", attrs, children) -> children, attrs
373 | _ -> failwith "get_xml_desc didn't return <domain/>" in
376 try Some (int_of_string (List.assoc "id" domain_attrs))
377 with Not_found -> None in
379 let rec loop = function
381 failwith "get_xml_desc returned no <name> node in XML"
382 | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
383 | Xml.Element ("name", _, _) :: _ ->
384 failwith "get_xml_desc returned strange <name> node"
385 | _ :: rest -> loop rest
387 let name = loop nodes in
393 | Xml.Element ("devices", _, devices) -> Some devices
396 List.concat devices in
398 let rec target_dev_of = function
400 | Xml.Element ("target", attrs, _) :: rest ->
401 (try Some (List.assoc "dev" attrs)
402 with Not_found -> target_dev_of rest)
403 | _ :: rest -> target_dev_of rest
406 let rec source_file_of = function
408 | Xml.Element ("source", attrs, _) :: rest ->
409 (try Some (List.assoc "file" attrs)
410 with Not_found -> source_file_of rest)
411 | _ :: rest -> source_file_of rest
414 let rec source_dev_of = function
416 | Xml.Element ("source", attrs, _) :: rest ->
417 (try Some (List.assoc "dev" attrs)
418 with Not_found -> source_dev_of rest)
419 | _ :: rest -> source_dev_of rest
425 | Xml.Element ("disk", attrs, children) ->
427 try Some (List.assoc "type" attrs)
428 with Not_found -> None in
430 try Some (List.assoc "device" attrs)
431 with Not_found -> None in
433 match source_file_of children with
434 | (Some _) as source -> source
435 | None -> source_dev_of children in
436 let target = target_dev_of children in
439 d_type = typ; d_device = device;
440 d_source = source; d_target = target
445 { dom_name = name; dom_id = domid; dom_disks = disks }
448 (* Probe the devices. *)
450 fun { dom_name = dom_name; dom_disks = dom_disks } ->
453 | { d_source = Some source; d_target = Some target } ->
454 probe_device dom_name target source
455 | { d_device = Some "cdrom" } ->
456 () (* Ignore physical CD-ROM devices. *)
458 printf "(device omitted)\n";