virt-df/virt_df.ml

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