virt-df/virt_df.ml

   1 (* 'df' command for virtual domains.
   2    (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   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.
   9
  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.
  14
  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.
  18  *)
  19
  20 open Printf
  21 open ExtList
  22
  23 open Unix
  24
  25 module C = Libvirt.Connect
  26 module D = Libvirt.Domain
  27 module N = Libvirt.Network
  28
  29 (* Int64 operators for convenience.
  30  * For sanity we do all int operations as int64's.
  31  *)
  32 let (+^) = Int64.add
  33 let (-^) = Int64.sub
  34 let ( *^ ) = Int64.mul
  35 let (/^) = Int64.div
  36
  37 let uri = ref None
  38 let inodes = ref false
  39 let human = ref false
  40 let all = ref false
  41
  42 (* Maximum number of extended partitions possible. *)
  43 let max_extended_partitions = 100
  44
  45 let sector_size = 512L
  46
  47 (* Parse out the device XML to get the names of disks. *)
  48 type domain = {
  49   dom_name : string;                    (* Domain name. *)
  50   dom_id : int option;                  (* Domain ID (if running). *)
  51   dom_disks : disk list;                (* Domain disks. *)
  52 }
  53 and disk = {
  54   d_type : string option;               (* The <disk type=...> *)
  55   d_device : string option;             (* The <disk device=...> *)
  56   d_source : string option;             (* The <source file=... or dev> *)
  57   d_target : string option;             (* The <target dev=...> *)
  58 }
  59
  60 type partition = {
  61   part_status : partition_status;       (* Bootable, etc. *)
  62   part_type : int;                      (* Partition type. *)
  63   part_lba_start : int64;               (* LBA start sector. *)
  64   part_len : int64;                     (* Length in sectors. *)
  65 }
  66 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
  67
  68 type filesystem_stats = {
  69   fs_name : string;
  70   fs_block_size : int64;                (* Block size (bytes). *)
  71   fs_blocks_total : int64;              (* Total blocks. *)
  72   fs_blocks_reserved : int64;           (* Blocks reserved for super-user. *)
  73   fs_blocks_avail : int64;              (* Blocks free (available). *)
  74   fs_blocks_used : int64;               (* Blocks in use. *)
  75   fs_inodes_total : int64;              (* Total inodes. *)
  76   fs_inodes_reserved : int64;           (* Inodes reserved for super-user. *)
  77   fs_inodes_avail : int64;              (* Inodes free (available). *)
  78   fs_inodes_used : int64;               (* Inodes in use. *)
  79 }
  80 and swap_stats = {
  81   swap_name : string;
  82   swap_block_size : int64;              (* Block size (bytes). *)
  83   swap_blocks_total : int64;            (* Total blocks. *)
  84 }
  85 and fs_probe_t =                        (* Return type of the probe_partition.*)
  86   | Filesystem of filesystem_stats
  87   | Swap of swap_stats
  88   | ProbeFailed of string               (* Probe failed for some reason. *)
  89   | ProbeIgnore                         (* This filesystem should be ignored. *)
  90
  91 (* Register a filesystem type. *)
  92 let filesystems = Hashtbl.create 13
  93 let fs_register part_types probe_fn =
  94   List.iter
  95     (fun part_type -> Hashtbl.replace filesystems part_type probe_fn)
  96     part_types
  97
  98 (* Probe the devices and display.
  99  * - dom_name is the domain name
 100  * - target will be something like "hda"
 101  * - source will be the name of a file or disk partition on the local machine
 102  *)
 103 let rec probe_device dom_name target source =
 104   let fd = openfile source [ O_RDONLY ] 0 in
 105   let size = (LargeFile.fstat fd).LargeFile.st_size in
 106   let size = size /^ sector_size in     (* Size in sectors. *)
 107
 108   (*print_device dom_name target source size;*)
 109
 110   let partitions = probe_mbr fd in
 111
 112   if partitions <> [] then (
 113     let stats =
 114       List.mapi (
 115         fun i part ->
 116           if part.part_status = Bootable ||
 117             part.part_status = Nonbootable then (
 118               let pnum = i+1 in
 119               let target = target ^ string_of_int pnum in
 120               Some (target,
 121                     probe_partition target (Some part.part_type)
 122                       fd part.part_lba_start part.part_len)
 123             )
 124           else
 125             None
 126       ) partitions in
 127     let stats = List.filter_map (fun x -> x) stats in
 128     print_stats dom_name stats
 129   ) else             (* Not an MBR, assume it's a single partition. *)
 130     print_stats dom_name [target, probe_partition target None fd 0L size];
 131
 132   close fd
 133
 134 (* Probe the master boot record (if it is one) and read the partitions.
 135  * Returns [] if this is not an MBR.
 136  * http://en.wikipedia.org/wiki/Master_boot_record
 137  *)
 138 and probe_mbr fd =
 139   lseek fd 510 SEEK_SET;
 140   let str = String.create 2 in
 141   if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then
 142     [] (* Not MBR *)
 143   else (
 144     (* Read the partition table. *)
 145     lseek fd 446 SEEK_SET;
 146     let str = String.create 64 in
 147     if read fd str 0 64 <> 64 then
 148       failwith "error reading partition table"
 149     else (
 150       (* Extract partitions from the data. *)
 151       let primaries = List.map (get_partition str) [ 0; 16; 32; 48 ] in
 152       (* XXX validate partition extents compared to disk. *)
 153       (* Read extended partition data. *)
 154       let extendeds = List.map (
 155         function
 156         | { part_type = 0x05 } as part ->
 157             probe_extended_partition
 158               max_extended_partitions fd part part.part_lba_start
 159         | part -> []
 160       ) primaries in
 161       let extendeds = List.concat extendeds in
 162       primaries @ extendeds
 163     )
 164   )
 165
 166 (* Probe an extended partition. *)
 167 and probe_extended_partition max fd epart sect =
 168   if max > 0 then (
 169     (* Offset of the first EBR. *)
 170     let ebr_offs = sect *^ sector_size in
 171     (* EBR Signature? *)
 172     LargeFile.lseek fd (ebr_offs +^ 510L) SEEK_SET;
 173     let str = String.create 2 in
 174     if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then
 175       [] (* Not EBR *)
 176     else (
 177       (* Read the extended partition table entries (just 2 of them). *)
 178       LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET;
 179       let str = String.create 32 in
 180       if read fd str 0 32 <> 32 then
 181         failwith "error reading extended partition"
 182       else (
 183         (* Extract partitions from the data. *)
 184         let part1, part2 =
 185           match List.map (get_partition str) [ 0; 16 ] with
 186           | [p1;p2] -> p1,p2
 187           | _ -> failwith "probe_extended_partition: internal error" in
 188         (* First partition entry has offset to the start of this partition. *)
 189         let part1 = { part1 with
 190                         part_lba_start = sect +^ part1.part_lba_start } in
 191         (* Second partition entry is zeroes if end of list, otherwise points
 192          * to the next partition.
 193          *)
 194         if part2.part_status = NullEntry then
 195           [part1]
 196         else
 197           part1 :: probe_extended_partition
 198                      (max-1) fd epart (sect +^ part2.part_lba_start)
 199       )
 200     )
 201   )
 202   else []
 203
 204 (* Get the partition data from str.[offs] - str.[offs+15] *)
 205 and get_partition str offs =
 206   let part_type = Char.code str.[offs+4] in
 207   let part_lba_start = read_int32_le str (offs+8) in
 208   let part_len = read_int32_le str (offs+12) in
 209
 210   let part_status =
 211     if part_type = 0 && part_lba_start = 0L && part_len = 0L then
 212       NullEntry
 213     else (
 214       let part_status = Char.code str.[offs] in
 215       match part_status with
 216       | 0x80 -> Bootable | 0 -> Nonbootable | _ -> Malformed
 217     ) in
 218
 219   { part_status = part_status;
 220     part_type = part_type;
 221     part_lba_start = part_lba_start;
 222     part_len = part_len }
 223
 224 (* Probe a single partition, which we assume contains either a
 225  * filesystem or is a PV.
 226  * - target will be something like "hda" or "hda1"
 227  * - part_type will be the partition type if known, or None
 228  * - fd is a file descriptor opened on the device
 229  * - start & size are where we think the start and size of the
 230  *   partition is within the file descriptor (in SECTORS)
 231  *)
 232 and probe_partition target part_type fd start size =
 233   match part_type with
 234   | None ->
 235       ProbeFailed "detection of unpartitioned devices not yet supported"
 236   | Some 0x05 ->
 237       ProbeIgnore (* Extended partition - ignore it. *)
 238   | Some part_type ->
 239       try
 240         let probe_fn = Hashtbl.find filesystems part_type in
 241         probe_fn target part_type fd start size
 242       with
 243         Not_found ->
 244           ProbeFailed
 245             (sprintf "unsupported partition type %02x" part_type)
 246
 247 and print_stats dom_name statss =
 248   List.iter (
 249     fun (target, fs_probe_t) ->
 250       let dom_target = dom_name ^ ":" ^ target in
 251       printf "%-20s " dom_target;
 252
 253       match fs_probe_t with
 254       (* Swap partition. *)
 255       | Swap { swap_name = swap_name;
 256                swap_block_size = block_size;
 257                swap_blocks_total = blocks_total } ->
 258           if not !human then
 259             printf "%10Ld                       %s\n"
 260               (block_size *^ blocks_total /^ 1024L) swap_name
 261           else
 262             printf "%10s                       %s\n"
 263               (printable_size (block_size *^ blocks_total)) swap_name
 264
 265       (* Ordinary filesystem. *)
 266       | Filesystem stats ->
 267           if not !inodes then (         (* Block display. *)
 268             (* 'df' doesn't count the restricted blocks. *)
 269             let blocks_total =
 270               stats.fs_blocks_total -^ stats.fs_blocks_reserved in
 271             let blocks_avail =
 272               stats.fs_blocks_avail -^ stats.fs_blocks_reserved in
 273             let blocks_avail =
 274               if blocks_avail < 0L then 0L else blocks_avail in
 275
 276             if not !human then (        (* Display 1K blocks. *)
 277               printf "%10Ld %10Ld %10Ld %s\n"
 278                 (blocks_total *^ stats.fs_block_size /^ 1024L)
 279                 (stats.fs_blocks_used *^ stats.fs_block_size /^ 1024L)
 280                 (blocks_avail *^ stats.fs_block_size /^ 1024L)
 281                 stats.fs_name
 282             ) else (                    (* Human-readable blocks. *)
 283               printf "%10s %10s %10s %s\n"
 284                 (printable_size (blocks_total *^ stats.fs_block_size))
 285                 (printable_size (stats.fs_blocks_used *^ stats.fs_block_size))
 286                 (printable_size (blocks_avail *^ stats.fs_block_size))
 287                 stats.fs_name
 288             )
 289           ) else (                      (* Inodes display. *)
 290             printf "%10Ld %10Ld %10Ld %s\n"
 291               stats.fs_inodes_total stats.fs_inodes_used stats.fs_inodes_avail
 292               stats.fs_name
 293           )
 294
 295       (* Unsupported filesystem or other failure. *)
 296       | ProbeFailed reason ->
 297           printf "                                 %s\n" reason
 298
 299       | ProbeIgnore -> ()
 300   ) statss
 301
 302 (* Target is something like "hda" and size is the size in sectors. *)
 303 and print_device dom_name target source size =
 304   printf "%s /dev/%s (%s) %s\n"
 305     dom_name target (printable_size (size *^ sector_size)) source
 306
 307 and printable_size bytes =
 308   if bytes < 1024L *^ 1024L then
 309     sprintf "%Ld bytes" bytes
 310   else if bytes < 1024L *^ 1024L *^ 1024L then
 311     sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
 312   else
 313     sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
 314
 315 and read_int32_le str offs =
 316   Int64.of_int (Char.code str.[offs]) +^
 317     256L *^ Int64.of_int (Char.code str.[offs+1]) +^
 318     65536L *^ Int64.of_int (Char.code str.[offs+2]) +^
 319     16777216L *^ Int64.of_int (Char.code str.[offs+3])
 320
 321 and read_int16_le str offs =
 322   Int64.of_int (Char.code str.[offs]) +^
 323     256L *^ Int64.of_int (Char.code str.[offs+1])
 324
 325 let main () =
 326   (* Command line argument parsing. *)
 327   let set_uri = function "" -> uri := None | u -> uri := Some u in
 328
 329   let version () =
 330     printf "virt-df %s\n" (Libvirt_version.version);
 331
 332     let major, minor, release =
 333       let v, _ = Libvirt.get_version () in
 334       v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
 335     printf "libvirt %d.%d.%d\n" major minor release;
 336     exit 0
 337   in
 338
 339   let argspec = Arg.align [
 340     "-a", Arg.Set all, " Show all domains (default: only active domains)";
 341     "--all", Arg.Set all, " Show all domains (default: only active domains)";
 342     "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)";
 343     "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)";
 344     "-h", Arg.Set human, " Print sizes in human-readable format";
 345     "--human-readable", Arg.Set human, " Print sizes in human-readable format";
 346     "-i", Arg.Set inodes, " Show inodes instead of blocks";
 347     "--inodes", Arg.Set inodes, " Show inodes instead of blocks";
 348     "--version", Arg.Unit version, " Display version and exit";
 349   ] in
 350
 351   let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in
 352   let usage_msg = "virt-df : like 'df', shows disk space used in guests
 353
 354 SUMMARY
 355   virt-df [-options]
 356
 357 OPTIONS" in
 358
 359   Arg.parse argspec anon_fun usage_msg;
 360
 361   let xmls =
 362     (* Connect to the hypervisor. *)
 363     let conn =
 364       let name = !uri in
 365       try C.connect_readonly ?name ()
 366       with
 367         Libvirt.Virterror err ->
 368           prerr_endline (Libvirt.Virterror.to_string err);
 369           (* If non-root and no explicit connection URI, print a warning. *)
 370           if geteuid () <> 0 && name = None then (
 371             print_endline "NB: If you want to monitor a local Xen hypervisor, you usually need to be root";
 372           );
 373           exit 1 in
 374
 375     (* Get the list of active & inactive domains. *)
 376     let doms =
 377       let nr_active_doms = C.num_of_domains conn in
 378       let active_doms = Array.to_list (C.list_domains conn nr_active_doms) in
 379       let active_doms = List.map (D.lookup_by_id conn) active_doms in
 380       if not !all then
 381         active_doms
 382       else (
 383         let nr_inactive_doms = C.num_of_defined_domains conn in
 384         let inactive_doms =
 385           Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
 386         let inactive_doms = List.map (D.lookup_by_name conn) inactive_doms in
 387         active_doms @ inactive_doms
 388       ) in
 389
 390     (* Get their XML. *)
 391     let xmls = List.map D.get_xml_desc doms in
 392
 393     (* Parse the XML. *)
 394     let xmls = List.map Xml.parse_string xmls in
 395
 396     (* Return just the XML documents - everything else will be closed
 397      * and freed including the connection to the hypervisor.
 398      *)
 399     xmls in
 400
 401   let doms : domain list =
 402     (* Grr.. Need to use a library which has XPATH support (or cduce). *)
 403     List.map (
 404       fun xml ->
 405         let nodes, domain_attrs =
 406           match xml with
 407           | Xml.Element ("domain", attrs, children) -> children, attrs
 408           | _ -> failwith "get_xml_desc didn't return <domain/>" in
 409
 410         let domid =
 411           try Some (int_of_string (List.assoc "id" domain_attrs))
 412           with Not_found -> None in
 413
 414         let rec loop = function
 415           | [] ->
 416               failwith "get_xml_desc returned no <name> node in XML"
 417           | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
 418           | Xml.Element ("name", _, _) :: _ ->
 419               failwith "get_xml_desc returned strange <name> node"
 420           | _ :: rest -> loop rest
 421         in
 422         let name = loop nodes in
 423
 424         let devices =
 425           let devices =
 426             List.filter_map (
 427               function
 428               | Xml.Element ("devices", _, devices) -> Some devices
 429               | _ -> None
 430             ) nodes in
 431           List.concat devices in
 432
 433         let rec target_dev_of = function
 434           | [] -> None
 435           | Xml.Element ("target", attrs, _) :: rest ->
 436               (try Some (List.assoc "dev" attrs)
 437                with Not_found -> target_dev_of rest)
 438           | _ :: rest -> target_dev_of rest
 439         in
 440
 441         let rec source_file_of = function
 442           | [] -> None
 443           | Xml.Element ("source", attrs, _) :: rest ->
 444               (try Some (List.assoc "file" attrs)
 445                with Not_found -> source_file_of rest)
 446           | _ :: rest -> source_file_of rest
 447         in
 448
 449         let rec source_dev_of = function
 450           | [] -> None
 451           | Xml.Element ("source", attrs, _) :: rest ->
 452               (try Some (List.assoc "dev" attrs)
 453                with Not_found -> source_dev_of rest)
 454           | _ :: rest -> source_dev_of rest
 455         in
 456
 457         let disks =
 458           List.filter_map (
 459             function
 460             | Xml.Element ("disk", attrs, children) ->
 461                 let typ =
 462                   try Some (List.assoc "type" attrs)
 463                   with Not_found -> None in
 464                 let device =
 465                   try Some (List.assoc "device" attrs)
 466                   with Not_found -> None in
 467                 let source =
 468                   match source_file_of children with
 469                   | (Some _) as source -> source
 470                   | None -> source_dev_of children in
 471                 let target = target_dev_of children in
 472
 473                 Some {
 474                   d_type = typ; d_device = device;
 475                   d_source = source; d_target = target
 476                 }
 477             | _ -> None
 478           ) devices in
 479
 480         { dom_name = name; dom_id = domid; dom_disks = disks }
 481     ) xmls in
 482
 483   (* Print the title. *)
 484   let () =
 485     let total, used, avail =
 486       match !inodes, !human with
 487       | false, false -> "1K-blocks", "Used", "Available"
 488       | false, true -> "Size", "Used", "Available"
 489       | true, _ -> "Inodes", "IUse", "IFree" in
 490     printf "%-20s %10s %10s %10s %s\n%!"
 491       "Filesystem" total used avail "Type" in
 492
 493   (* Probe the devices. *)
 494   List.iter (
 495     fun { dom_name = dom_name; dom_disks = dom_disks } ->
 496       List.iter (
 497         function
 498         | { d_source = Some source; d_target = Some target } ->
 499             probe_device dom_name target source
 500         | { d_device = Some "cdrom" } ->
 501             () (* Ignore physical CD-ROM devices. *)
 502         | _ ->
 503             printf "(device omitted)\n";
 504       ) dom_disks
 505   ) doms