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