path: root/virt-df/virt_df.ml

(* 'df' command for virtual domains.
   (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
   http://libvirt.org/

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *)

open Printf
open ExtList
open Unix

open Virt_df_gettext.Gettext

module C = Libvirt.Connect
module D = Libvirt.Domain
module N = Libvirt.Network

(* Int64 operators for convenience.
 * For sanity we do all int operations as int64's.
 *)
let (+^) = Int64.add
let (-^) = Int64.sub
let ( *^ ) = Int64.mul
let (/^) = Int64.div

let uri = ref None
let inodes = ref false
let human = ref false
let all = ref false

(* Maximum number of extended partitions possible. *)
let max_extended_partitions = 100

let sector_size = 512L

(* Parse out the device XML to get the names of disks. *)
type domain = {
  dom_name : string;			(* Domain name. *)
  dom_id : int option;			(* Domain ID (if running). *)
  dom_disks : disk list;		(* Domain disks. *)
}
and disk = {
  d_type : string option;		(* The <disk type=...> *)
  d_device : string option;		(* The <disk device=...> *)
  d_source : string option;		(* The <source file=... or dev> *)
  d_target : string option;		(* The <target dev=...> *)
}

type partition = {
  part_status : partition_status;	(* Bootable, etc. *)
  part_type : int;			(* Partition type. *)
  part_lba_start : int64;		(* LBA start sector. *)
  part_len : int64;			(* Length in sectors. *)
}
and partition_status = Bootable | Nonbootable | Malformed | NullEntry

type filesystem_stats = {
  fs_name : string;
  fs_block_size : int64;		(* Block size (bytes). *)
  fs_blocks_total : int64;		(* Total blocks. *)
  fs_blocks_reserved : int64;		(* Blocks reserved for super-user. *)
  fs_blocks_avail : int64;		(* Blocks free (available). *)
  fs_blocks_used : int64;		(* Blocks in use. *)
  fs_inodes_total : int64;		(* Total inodes. *)
  fs_inodes_reserved : int64;		(* Inodes reserved for super-user. *)
  fs_inodes_avail : int64;		(* Inodes free (available). *)
  fs_inodes_used : int64;		(* Inodes in use. *)
}
and swap_stats = {
  swap_name : string;
  swap_block_size : int64;		(* Block size (bytes). *)
  swap_blocks_total : int64;		(* Total blocks. *)
}
and fs_probe_t =			(* Return type of the probe_partition.*)
  | Filesystem of filesystem_stats
  | Swap of swap_stats
  | ProbeFailed of string		(* Probe failed for some reason. *)
  | ProbeIgnore				(* This filesystem should be ignored. *)

(* Register a filesystem type. *)
let filesystems = Hashtbl.create 13
let fs_register part_types probe_fn =
  List.iter
    (fun part_type -> Hashtbl.replace filesystems part_type probe_fn)
    part_types

(* Probe the devices and display.
 * - dom_name is the domain name
 * - target will be something like "hda"
 * - source will be the name of a file or disk partition on the local machine
 *)
let rec probe_device dom_name target source =
  let fd = openfile source [ O_RDONLY ] 0 in
  let size = (LargeFile.fstat fd).LargeFile.st_size in
  let size = size /^ sector_size in	(* Size in sectors. *)

  (*print_device dom_name target source size;*)

  let partitions = probe_mbr fd in

  if partitions <> [] then (
    let stats =
      List.mapi (
	fun i part ->
	  if part.part_status = Bootable ||
	    part.part_status = Nonbootable then (
	      let pnum = i+1 in
	      let target = target ^ string_of_int pnum in
	      Some (target,
		    probe_partition target (Some part.part_type)
		      fd part.part_lba_start part.part_len)
	    )
	  else
	    None
      ) partitions in
    let stats = List.filter_map (fun x -> x) stats in
    print_stats dom_name stats
  ) else	     (* Not an MBR, assume it's a single partition. *)
    print_stats dom_name [target, probe_partition target None fd 0L size];

  close fd

(* Probe the master boot record (if it is one) and read the partitions.
 * Returns [] if this is not an MBR.
 * http://en.wikipedia.org/wiki/Master_boot_record
 *)
and probe_mbr fd =
  lseek fd 510 SEEK_SET;
  let str = String.create 2 in
  if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then
    [] (* Not MBR *)
  else (
    (* Read the partition table. *)
    lseek fd 446 SEEK_SET;
    let str = String.create 64 in
    if read fd str 0 64 <> 64 then
      failwith (s_ "error reading partition table")
    else (
      (* Extract partitions from the data. *)
      let primaries = List.map (get_partition str) [ 0; 16; 32; 48 ] in
      (* XXX validate partition extents compared to disk. *)
      (* Read extended partition data. *)
      let extendeds = List.map (
	function
	| { part_type = 0x05 } as part ->
	    probe_extended_partition
	      max_extended_partitions fd part part.part_lba_start
	| part -> []
      ) primaries in
      let extendeds = List.concat extendeds in
      primaries @ extendeds
    )
  )

(* Probe an extended partition. *)
and probe_extended_partition max fd epart sect =
  if max > 0 then (
    (* Offset of the first EBR. *)
    let ebr_offs = sect *^ sector_size in
    (* EBR Signature? *)
    LargeFile.lseek fd (ebr_offs +^ 510L) SEEK_SET;
    let str = String.create 2 in
    if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then
      [] (* Not EBR *)
    else (
      (* Read the extended partition table entries (just 2 of them). *)
      LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET;
      let str = String.create 32 in
      if read fd str 0 32 <> 32 then
	failwith (s_ "error reading extended partition")
      else (
	(* Extract partitions from the data. *)
	let part1, part2 =
	  match List.map (get_partition str) [ 0; 16 ] with
	  | [p1;p2] -> p1,p2
	  | _ -> failwith (s_ "probe_extended_partition: internal error") in
	(* First partition entry has offset to the start of this partition. *)
	let part1 = { part1 with
			part_lba_start = sect +^ part1.part_lba_start } in
	(* Second partition entry is zeroes if end of list, otherwise points
	 * to the next partition.
	 *)
	if part2.part_status = NullEntry then
	  [part1]
	else
	  part1 :: probe_extended_partition
	             (max-1) fd epart (sect +^ part2.part_lba_start)
      )
    )
  )
  else []

(* Get the partition data from str.[offs] - str.[offs+15] *)
and get_partition str offs =
  let part_type = Char.code str.[offs+4] in
  let part_lba_start = read_int32_le str (offs+8) in
  let part_len = read_int32_le str (offs+12) in

  let part_status =
    if part_type = 0 && part_lba_start = 0L && part_len = 0L then
      NullEntry
    else (
      let part_status = Char.code str.[offs] in
      match part_status with
      | 0x80 -> Bootable | 0 -> Nonbootable | _ -> Malformed
    ) in

  { part_status = part_status;
    part_type = part_type;
    part_lba_start = part_lba_start;
    part_len = part_len }

(* Probe a single partition, which we assume contains either a
 * filesystem or is a PV.
 * - target will be something like "hda" or "hda1"
 * - part_type will be the partition type if known, or None
 * - fd is a file descriptor opened on the device
 * - start & size are where we think the start and size of the
 *   partition is within the file descriptor (in SECTORS)
 *)
and probe_partition target part_type fd start size =
  match part_type with
  | None ->
      ProbeFailed (s_ "detection of unpartitioned devices not yet supported")
  | Some 0x05 ->
      ProbeIgnore (* Extended partition - ignore it. *)
  | Some part_type ->
      try
	let probe_fn = Hashtbl.find filesystems part_type in
	probe_fn target part_type fd start size
      with
	Not_found ->
	  ProbeFailed
	    (sprintf (f_ "unsupported partition type %02x") part_type)

and print_stats dom_name statss =
  List.iter (
    fun (target, fs_probe_t) ->
      let dom_target = dom_name ^ ":" ^ target in
      printf "%-20s " dom_target;

      match fs_probe_t with
      (* Swap partition. *)
      | Swap { swap_name = swap_name;
	       swap_block_size = block_size;
	       swap_blocks_total = blocks_total } ->
	  if not !human then
	    printf "%10Ld                       %s\n"
	      (block_size *^ blocks_total /^ 1024L) swap_name
	  else
	    printf "%10s                       %s\n"
	      (printable_size (block_size *^ blocks_total)) swap_name

      (* Ordinary filesystem. *)
      | Filesystem stats ->
	  if not !inodes then (		(* Block display. *)
	    (* 'df' doesn't count the restricted blocks. *)
	    let blocks_total =
	      stats.fs_blocks_total -^ stats.fs_blocks_reserved in
	    let blocks_avail =
	      stats.fs_blocks_avail -^ stats.fs_blocks_reserved in
	    let blocks_avail =
	      if blocks_avail < 0L then 0L else blocks_avail in

	    if not !human then (	(* Display 1K blocks. *)
	      printf "%10Ld %10Ld %10Ld %s\n"
		(blocks_total *^ stats.fs_block_size /^ 1024L)
		(stats.fs_blocks_used *^ stats.fs_block_size /^ 1024L)
		(blocks_avail *^ stats.fs_block_size /^ 1024L)
		stats.fs_name
	    ) else (			(* Human-readable blocks. *)
	      printf "%10s %10s %10s %s\n"
		(printable_size (blocks_total *^ stats.fs_block_size))
		(printable_size (stats.fs_blocks_used *^ stats.fs_block_size))
		(printable_size (blocks_avail *^ stats.fs_block_size))
		stats.fs_name
	    )
	  ) else (			(* Inodes display. *)
	    printf "%10Ld %10Ld %10Ld %s\n"
	      stats.fs_inodes_total stats.fs_inodes_used stats.fs_inodes_avail
	      stats.fs_name
	  )

      (* Unsupported filesystem or other failure. *)
      | ProbeFailed reason ->
	  printf "                                 %s\n" reason

      | ProbeIgnore -> ()
  ) statss

(* Target is something like "hda" and size is the size in sectors. *)
and print_device dom_name target source size =
  printf "%s /dev/%s (%s) %s\n"
    dom_name target (printable_size (size *^ sector_size)) source

and printable_size bytes =
  if bytes < 1024L *^ 1024L then
    sprintf "%Ld bytes" bytes
  else if bytes < 1024L *^ 1024L *^ 1024L then
    sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
  else
    sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)

and read_int32_le str offs =
  Int64.of_int (Char.code str.[offs]) +^
    256L *^ Int64.of_int (Char.code str.[offs+1]) +^
    65536L *^ Int64.of_int (Char.code str.[offs+2]) +^
    16777216L *^ Int64.of_int (Char.code str.[offs+3])

and read_int16_le str offs =
  Int64.of_int (Char.code str.[offs]) +^
    256L *^ Int64.of_int (Char.code str.[offs+1])

let main () =
  (* Command line argument parsing. *)
  let set_uri = function "" -> uri := None | u -> uri := Some u in

  let version () =
    printf "virt-df %s\n" (Libvirt_version.version);

    let major, minor, release =
      let v, _ = Libvirt.get_version () in
      v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
    printf "libvirt %d.%d.%d\n" major minor release;
    exit 0
  in

  let argspec = Arg.align [
    "-a", Arg.Set all,
      " " ^ s_ "Show all domains (default: only active domains)";
    "--all", Arg.Set all,
      " " ^ s_ "Show all domains (default: only active domains)";
    "-c", Arg.String set_uri,
      "uri " ^ s_ "Connect to URI (default: Xen)";
    "--connect", Arg.String set_uri,
      "uri " ^ s_ "Connect to URI (default: Xen)";
    "-h", Arg.Set human,
      " " ^ s_ "Print sizes in human-readable format";
    "--human-readable", Arg.Set human,
      " " ^ s_ "Print sizes in human-readable format";
    "-i", Arg.Set inodes,
      " " ^ s_ "Show inodes instead of blocks";
    "--inodes", Arg.Set inodes,
      " " ^ s_ "Show inodes instead of blocks";
    "--version", Arg.Unit version,
      " " ^ s_ "Display version and exit";
  ] in

  let anon_fun str =
    raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
  let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests

SUMMARY
  virt-df [-options]

OPTIONS" in

  Arg.parse argspec anon_fun usage_msg;

  let xmls =
    (* Connect to the hypervisor. *)
    let conn =
      let name = !uri in
      try C.connect_readonly ?name ()
      with
	Libvirt.Virterror err ->
	  prerr_endline (Libvirt.Virterror.to_string err);
	  (* If non-root and no explicit connection URI, print a warning. *)
	  if geteuid () <> 0 && name = None then (
	    print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
	  );
	  exit 1 in

    (* Get the list of active & inactive domains. *)
    let doms =
      let nr_active_doms = C.num_of_domains conn in
      let active_doms = Array.to_list (C.list_domains conn nr_active_doms) in
      let active_doms = List.map (D.lookup_by_id conn) active_doms in
      if not !all then
	active_doms
      else (
	let nr_inactive_doms = C.num_of_defined_domains conn in
	let inactive_doms =
	  Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
	let inactive_doms = List.map (D.lookup_by_name conn) inactive_doms in
	active_doms @ inactive_doms
      ) in

    (* Get their XML. *)
    let xmls = List.map D.get_xml_desc doms in

    (* Parse the XML. *)
    let xmls = List.map Xml.parse_string xmls in

    (* Return just the XML documents - everything else will be closed
     * and freed including the connection to the hypervisor.
     *)
    xmls in

  let doms : domain list =
    (* Grr.. Need to use a library which has XPATH support (or cduce). *)
    List.map (
      fun xml ->
	let nodes, domain_attrs =
	  match xml with
	  | Xml.Element ("domain", attrs, children) -> children, attrs
	  | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in

	let domid =
	  try Some (int_of_string (List.assoc "id" domain_attrs))
	  with Not_found -> None in

	let rec loop = function
	  | [] ->
	      failwith (s_ "get_xml_desc returned no <name> node in XML")
	  | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
	  | Xml.Element ("name", _, _) :: _ ->
	      failwith (s_ "get_xml_desc returned strange <name> node")
	  | _ :: rest -> loop rest
	in
	let name = loop nodes in

	let devices =
	  let devices =
	    List.filter_map (
	      function
	      | Xml.Element ("devices", _, devices) -> Some devices
	      | _ -> None
	    ) nodes in
	  List.concat devices in

	let rec target_dev_of = function
	  | [] -> None
	  | Xml.Element ("target", attrs, _) :: rest ->
	      (try Some (List.assoc "dev" attrs)
	       with Not_found -> target_dev_of rest)
	  | _ :: rest -> target_dev_of rest
	in

	let rec source_file_of = function
	  | [] -> None
	  | Xml.Element ("source", attrs, _) :: rest ->
	      (try Some (List.assoc "file" attrs)
	       with Not_found -> source_file_of rest)
	  | _ :: rest -> source_file_of rest
	in

	let rec source_dev_of = function
	  | [] -> None
	  | Xml.Element ("source", attrs, _) :: rest ->
	      (try Some (List.assoc "dev" attrs)
	       with Not_found -> source_dev_of rest)
	  | _ :: rest -> source_dev_of rest
	in

	let disks =
	  List.filter_map (
	    function
	    | Xml.Element ("disk", attrs, children) ->
		let typ =
		  try Some (List.assoc "type" attrs)
		  with Not_found -> None in
		let device =
		  try Some (List.assoc "device" attrs)
		  with Not_found -> None in
		let source =
		  match source_file_of children with
		  | (Some _) as source -> source
		  | None -> source_dev_of children in
		let target = target_dev_of children in

		Some {
		  d_type = typ; d_device = device;
		  d_source = source; d_target = target
		}
	    | _ -> None
	  ) devices in

	{ dom_name = name; dom_id = domid; dom_disks = disks }
    ) xmls in

  (* Print the title. *)
  let () =
    let total, used, avail =
      match !inodes, !human with
      | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available"
      | false, true -> s_ "Size", s_ "Used", s_ "Available"
      | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in
    printf "%-20s %10s %10s %10s %s\n%!"
      (s_ "Filesystem") total used avail (s_ "Type") in

  (* Probe the devices. *)
  List.iter (
    fun { dom_name = dom_name; dom_disks = dom_disks } ->
      List.iter (
	function
	| { d_source = Some source; d_target = Some target } ->
	    probe_device dom_name target source
	| { d_device = Some "cdrom" } ->
	    () (* Ignore physical CD-ROM devices. *)
	| _ ->
	    print_endline (s_ "(device omitted)");
      ) dom_disks
  ) doms