virt-df/virt_df.ml

   1 (* 'df' command for virtual domains.
   2  * $Id$
   3  *)
   4
   5 open Printf
   6 open ExtList
   7
   8 open Unix
   9
  10 module C = Libvirt.Connect
  11 module D = Libvirt.Domain
  12 module N = Libvirt.Network
  13
  14 (* Int64 operators for convenience.
  15  * For sanity we do all int operations as int64's.
  16  *)
  17 let (+^) = Int64.add
  18 let (-^) = Int64.sub
  19 let ( *^ ) = Int64.mul
  20 let (/^) = Int64.div
  21
  22 let uri = ref None
  23 let inodes = ref false
  24 let human = ref false
  25
  26 (* Maximum number of extended partitions possible. *)
  27 let max_extended_partitions = 100
  28
  29 let sector_size = 512L
  30
  31 (* Parse out the device XML to get the names of disks. *)
  32 type domain = {
  33   dom_name : string;                    (* Domain name. *)
  34   dom_id : int option;                  (* Domain ID (if running). *)
  35   dom_disks : disk list;                (* Domain disks. *)
  36 }
  37 and disk = {
  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=...> *)
  42 }
  43
  44 type partition = {
  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. *)
  49 }
  50 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
  51
  52 type filesystem_stats = {
  53   fs_name : string;
  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. *)
  63 }
  64 and swap_stats = {
  65   swap_name : string;
  66   swap_block_size : int64;              (* Block size (bytes). *)
  67   swap_blocks_total : int64;            (* Total blocks. *)
  68 }
  69 and fs_probe_t =                        (* Return type of the probe_partition.*)
  70   | Filesystem of filesystem_stats
  71   | Swap of swap_stats
  72   | ProbeFailed of string               (* Probe failed for some reason. *)
  73   | ProbeIgnore                         (* This filesystem should be ignored. *)
  74
  75 (* Register a filesystem type. *)
  76 let filesystems = Hashtbl.create 13
  77 let fs_register part_types probe_fn =
  78   List.iter
  79     (fun part_type -> Hashtbl.replace filesystems part_type probe_fn)
  80     part_types
  81
  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
  86  *)
  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. *)
  91
  92   print_device dom_name target source size;
  93
  94   let partitions = probe_mbr fd in
  95
  96   if partitions <> [] then (
  97     let stats =
  98       List.mapi (
  99         fun i part ->
 100           if part.part_status = Bootable ||
 101             part.part_status = Nonbootable then (
 102               let pnum = i+1 in
 103               let target = target ^ string_of_int pnum in
 104               Some (target,
 105                     probe_partition target (Some part.part_type)
 106                       fd part.part_lba_start part.part_len)
 107             )
 108           else
 109             None
 110       ) partitions in
 111     let stats = List.filter_map (fun x -> x) stats in
 112     print_stats stats
 113   ) else             (* Not an MBR, assume it's a single partition. *)
 114     print_stats [target, probe_partition target None fd 0L size];
 115
 116   close fd
 117
 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
 121  *)
 122 and probe_mbr fd =
 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
 126     [] (* Not MBR *)
 127   else (
 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"
 133     else (
 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 (
 139         function
 140         | { part_type = 0x05 } as part ->
 141             probe_extended_partition
 142               max_extended_partitions fd part part.part_lba_start
 143         | part -> []
 144       ) primaries in
 145       let extendeds = List.concat extendeds in
 146       primaries @ extendeds
 147     )
 148   )
 149
 150 (* Probe an extended partition. *)
 151 and probe_extended_partition max fd epart sect =
 152   if max > 0 then (
 153     (* Offset of the first EBR. *)
 154     let ebr_offs = sect *^ sector_size in
 155     (* EBR Signature? *)
 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
 159       [] (* Not EBR *)
 160     else (
 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"
 166       else (
 167         (* Extract partitions from the data. *)
 168         let part1, part2 =
 169           match List.map (get_partition str) [ 0; 16 ] with
 170           | [p1;p2] -> p1,p2
 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.
 177          *)
 178         if part2.part_status = NullEntry then
 179           [part1]
 180         else
 181           part1 :: probe_extended_partition
 182                      (max-1) fd epart (sect +^ part2.part_lba_start)
 183       )
 184     )
 185   )
 186   else []
 187
 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
 193
 194   let part_status =
 195     if part_type = 0 && part_lba_start = 0L && part_len = 0L then
 196       NullEntry
 197     else (
 198       let part_status = Char.code str.[offs] in
 199       match part_status with
 200       | 0x80 -> Bootable | 0 -> Nonbootable | _ -> Malformed
 201     ) in
 202
 203   { part_status = part_status;
 204     part_type = part_type;
 205     part_lba_start = part_lba_start;
 206     part_len = part_len }
 207
 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)
 215  *)
 216 and probe_partition target part_type fd start size =
 217   match part_type with
 218   | None ->
 219       ProbeFailed "detection of unpartitioned devices not yet supported"
 220   | Some 0x05 ->
 221       ProbeIgnore (* Extended partition - ignore it. *)
 222   | Some part_type ->
 223       try
 224         let probe_fn = Hashtbl.find filesystems part_type in
 225         probe_fn target part_type fd start size
 226       with
 227         Not_found ->
 228           ProbeFailed
 229             (sprintf "unsupported partition type %02x" part_type)
 230
 231 and print_stats statss =
 232   List.iter (
 233     function
 234     (* Swap partition. *)
 235     | (target, Swap { swap_name = swap_name;
 236                       swap_block_size = block_size;
 237                       swap_blocks_total = blocks_total }) ->
 238         if not !human then
 239           printf "\t%s %Ld %s\n"
 240             target (block_size *^ blocks_total /^ 1024L) swap_name
 241         else
 242           printf "\t%s %s %s\n"
 243             target (printable_size (block_size *^ blocks_total)) swap_name
 244
 245     (* Ordinary filesystem. *)
 246     | (target, Filesystem stats) ->
 247         printf "\t%s " target;
 248
 249         if not !inodes then (           (* Block display. *)
 250           (* 'df' doesn't count the restricted blocks. *)
 251           let blocks_total =
 252             stats.fs_blocks_total -^ stats.fs_blocks_reserved in
 253           let blocks_avail =
 254             stats.fs_blocks_avail -^ stats.fs_blocks_reserved in
 255           let blocks_avail =
 256             if blocks_avail < 0L then 0L else blocks_avail in
 257
 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)
 263               stats.fs_name
 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))
 269               stats.fs_name
 270           )
 271         ) else (                        (* Inodes display. *)
 272           printf "%Ld %Ld %Ld %s\n"
 273             stats.fs_inodes_total stats.fs_inodes_used stats.fs_inodes_avail
 274             stats.fs_name
 275         )
 276
 277     (* Unsupported filesystem or other failure. *)
 278     | (target, ProbeFailed reason) ->
 279         printf "\t%s %s\n" target reason
 280
 281     | (_, ProbeIgnore) -> ()
 282   ) statss
 283
 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
 288
 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.)
 294   else
 295     sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
 296
 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])
 302
 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])
 306
 307 let main () =
 308   (* Command line argument parsing. *)
 309   let set_uri = function "" -> uri := None | u -> uri := Some u in
 310
 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";
 318   ] in
 319
 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
 322
 323 SUMMARY
 324   virt-df [-options]
 325
 326 OPTIONS" in
 327
 328   Arg.parse argspec anon_fun usage_msg;
 329
 330   let xmls =
 331     (* Connect to the hypervisor. *)
 332     let conn =
 333       let name = !uri in
 334       try C.connect_readonly ?name ()
 335       with
 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";
 341           );
 342           exit 1 in
 343
 344     (* Get the list of active & inactive domains. *)
 345     let doms =
 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
 350       let inactive_doms =
 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
 354
 355     (* Get their XML. *)
 356     let xmls = List.map D.get_xml_desc doms in
 357
 358     (* Parse the XML. *)
 359     let xmls = List.map Xml.parse_string xmls in
 360
 361     (* Return just the XML documents - everything else will be closed
 362      * and freed including the connection to the hypervisor.
 363      *)
 364     xmls in
 365
 366   let doms : domain list =
 367     (* Grr.. Need to use a library which has XPATH support (or cduce). *)
 368     List.map (
 369       fun xml ->
 370         let nodes, domain_attrs =
 371           match xml with
 372           | Xml.Element ("domain", attrs, children) -> children, attrs
 373           | _ -> failwith "get_xml_desc didn't return <domain/>" in
 374
 375         let domid =
 376           try Some (int_of_string (List.assoc "id" domain_attrs))
 377           with Not_found -> None in
 378
 379         let rec loop = function
 380           | [] ->
 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
 386         in
 387         let name = loop nodes in
 388
 389         let devices =
 390           let devices =
 391             List.filter_map (
 392               function
 393               | Xml.Element ("devices", _, devices) -> Some devices
 394               | _ -> None
 395             ) nodes in
 396           List.concat devices in
 397
 398         let rec target_dev_of = function
 399           | [] -> None
 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
 404         in
 405
 406         let rec source_file_of = function
 407           | [] -> None
 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
 412         in
 413
 414         let rec source_dev_of = function
 415           | [] -> None
 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
 420         in
 421
 422         let disks =
 423           List.filter_map (
 424             function
 425             | Xml.Element ("disk", attrs, children) ->
 426                 let typ =
 427                   try Some (List.assoc "type" attrs)
 428                   with Not_found -> None in
 429                 let device =
 430                   try Some (List.assoc "device" attrs)
 431                   with Not_found -> None in
 432                 let source =
 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
 437
 438                 Some {
 439                   d_type = typ; d_device = device;
 440                   d_source = source; d_target = target
 441                 }
 442             | _ -> None
 443           ) devices in
 444
 445         { dom_name = name; dom_id = domid; dom_disks = disks }
 446     ) xmls in
 447
 448   (* Probe the devices. *)
 449   List.iter (
 450     fun { dom_name = dom_name; dom_disks = dom_disks } ->
 451       List.iter (
 452         function
 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. *)
 457         | _ ->
 458             printf "(device omitted)\n";
 459       ) dom_disks
 460   ) doms