virt-df/virt_df.ml

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