X-Git-Url: http://git.annexia.org/?p=virt-top.git;a=blobdiff_plain;f=virt-df%2Fvirt_df_main.ml;h=65d1f2fc76afb401ee3b00394744de0abc2110ab;hp=bc4096b807e585788084f0a4966a87257a37da6c;hb=4cb0481ebc30cdb05d1a0e8672e5dda8cd2352c2;hpb=9bb5f67c0d8a6e8dad7de72e2488ee73c90f7d43

diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml
index bc4096b..65d1f2f 100644
--- a/virt-df/virt_df_main.ml
+++ b/virt-df/virt_df_main.ml
@@ -17,4 +17,472 @@
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  *)
 
-let () = Virt_df.main ()
+open Printf
+open ExtList
+open Unix
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+
+open Virt_df_gettext.Gettext
+open Virt_df
+
+let () =
+  (* 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 test_mode filename =
+    test_files := filename :: !test_files
+  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)";
+    "--debug", Arg.Set debug,
+      " " ^ s_ "Debug mode (default: false)";
+    "-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";
+    "-t", Arg.String test_mode,
+      "dev " ^ s_ "(Test mode) Display contents of block device or file";
+    "--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 doms : domain list =
+    if !test_files = [] then (
+      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
+
+      (* 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
+
+		  (* We only care about devices where we have
+		   * source and target.  Ignore CD-ROM devices.
+		   *)
+		  (match source, target, device with
+		   | _, _, Some "cdrom" -> None (* ignore *)
+		   | Some source, Some target, Some device ->
+		       (* Try to create a 'device' object for this
+			* device.  If it fails, print a warning
+			* and ignore the device.
+			*)
+		       (try
+			  let dev = new block_device source in
+			  Some {
+			    d_type = typ; d_device = device;
+			    d_source = source; d_target = target;
+			    d_dev = dev; d_content = `Unknown
+			  }
+			with
+			  Unix_error (err, func, param) ->
+			    eprintf "%s:%s: %s" func param (error_message err);
+			    None
+		       )
+		   | _ -> None (* ignore anything else *)
+		  )
+
+	      | _ -> None
+	    ) devices in
+
+	  { dom_name = name; dom_id = domid;
+	    dom_disks = disks; dom_lv_filesystems = [] }
+      ) xmls
+    ) else (
+      (* In test mode (-t option) the user can pass one or more
+       * block devices or filenames (containing partitions/filesystems/etc)
+       * which we use for testing virt-df itself.  We create fake domains
+       * from these.
+       *)
+      List.map (
+	fun filename ->
+	  {
+	    dom_name = filename; dom_id = None;
+	    dom_disks = [
+	      {
+		d_type = Some "disk"; d_device = "disk";
+		d_source = filename; d_target = "hda";
+		d_dev = new block_device filename; d_content = `Unknown;
+	      }
+	    ];
+	    dom_lv_filesystems = []
+	  }
+      ) !test_files
+    ) in
+
+  (* HOF to map over disks. *)
+  let map_over_disks doms f =
+    List.map (
+      fun ({ dom_disks = disks } as dom) ->
+	let disks = List.map f disks in
+	{ dom with dom_disks = disks }
+    ) doms
+  in
+
+  (* 'doms' is our list of domains and their guest block devices, and
+   * we've successfully opened each block device.  Now probe them
+   * to find out what they contain.
+   *)
+  let doms = map_over_disks doms (
+    fun ({ d_dev = dev } as disk) ->
+      (* See if it is partitioned first. *)
+      let parts = probe_for_partitions dev in
+      match parts with
+      | Some parts ->
+	  { disk with d_content = `Partitions parts }
+      | None ->
+	  (* Not partitioned.  Does it contain a filesystem? *)
+	  let fs = probe_for_filesystem dev in
+	  match fs with
+	  | Some fs ->
+	      { disk with d_content = `Filesystem fs }
+	  | None ->
+	      (* Not partitioned, no filesystem, is it a PV? *)
+	      let pv = probe_for_pv dev in
+	      match pv with
+	      | Some lvm_name ->
+		  { disk with d_content = `PhysicalVolume lvm_name }
+	      | None ->
+		  disk (* Spare/unknown. *)
+  ) in
+
+  (* Now we have either detected partitions or a filesystem on each
+   * physical device (or perhaps neither).  See what is on those
+   * partitions.
+   *)
+  let doms = map_over_disks doms (
+    function
+    | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
+	let ps = List.map (
+	  fun p ->
+	    if p.part_status = Bootable || p.part_status = Nonbootable then (
+	      let fs = probe_for_filesystem p.part_dev in
+	      match fs with
+	      | Some fs ->
+		  { p with part_content = `Filesystem fs }
+	      | None ->
+		  (* Is it a PV? *)
+		  let pv = probe_for_pv p.part_dev in
+		  match pv with
+		  | Some lvm_name ->
+		      { p with part_content = `PhysicalVolume lvm_name }
+		  | None ->
+		      p (* Spare/unknown. *)
+	    ) else p
+	) parts.parts in
+	let parts = { parts with parts = ps } in
+	{ disk with d_content = `Partitions parts }
+    | disk -> disk
+  ) in
+
+  (* LVM filesystem detection
+   *
+   * For each domain, look for all disks/partitions which have been
+   * identified as PVs and pass those back to the respective LVM
+   * plugin for LV detection.
+   *
+   * (Note - a two-stage process because an LV can be spread over
+   * several PVs, so we have to detect all PVs belonging to a
+   * domain first).
+   *
+   * XXX To deal with RAID (ie. md devices) we will need to loop
+   * around here because RAID is like LVM except that they normally
+   * present as block devices which can be used by LVM.
+   *)
+  (* First: LV detection. *)
+  let doms = List.map (
+    fun ({ dom_disks = disks } as dom) ->
+      (* Find all physical volumes, can be disks or partitions. *)
+      let pvs_on_disks = List.filter_map (
+	function
+	| { d_dev = d_dev;
+	    d_content = `PhysicalVolume pv } -> Some (pv, d_dev)
+	| _ -> None
+      ) disks in
+      let pvs_on_partitions = List.map (
+	function
+	| { d_content = `Partitions { parts = parts } } ->
+	    List.filter_map (
+	      function
+	      | { part_dev = part_dev;
+		  part_content = `PhysicalVolume pv } ->
+		    Some (pv, part_dev)
+	      | _ -> None
+	    ) parts
+	| _ -> []
+      ) disks in
+      let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in
+      dom, lvs
+  ) doms in
+
+  (* Second: filesystem on LV detection. *)
+  let doms = List.map (
+    fun (dom, lvs) ->
+      (* Group the LVs by plug-in type. *)
+      let cmp (a,_) (b,_) = compare a b in
+      let lvs = List.sort ~cmp lvs in
+      let lvs = group_by lvs in
+
+      let lvs =
+	List.map (fun (pv, devs) -> list_lvs pv.lvm_plugin_id devs) lvs in
+      let lvs = List.concat lvs in
+
+      (* lvs is a list of potential LV devices.  Now run them through the
+       * probes to see if any contain filesystems.
+       *)
+      let filesystems =
+	List.filter_map (
+	  fun ({ lv_dev = dev } as lv) ->
+	    match probe_for_filesystem dev with
+	    | Some fs -> Some (lv, fs)
+	    | None -> None
+	) lvs in
+
+      { dom with dom_lv_filesystems = filesystems }
+  ) doms in
+
+  (* Now print the results.
+   *
+   * 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
+
+  let 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.)
+  in
+
+  (* HOF to iterate over filesystems. *)
+  let iter_over_filesystems doms
+      (f : domain -> ?disk:disk -> ?partno:int -> device -> filesystem ->
+	unit) =
+    List.iter (
+      fun ({ dom_disks = disks; dom_lv_filesystems = filesystems } as dom) ->
+	(* Ordinary filesystems found on disks & partitions. *)
+	List.iter (
+	  function
+	  | ({ d_content = `Filesystem fs; d_dev = dev } as disk) ->
+	      f dom ~disk dev fs
+	  | ({ d_content = `Partitions partitions } as disk) ->
+	      List.iteri (
+		fun i ->
+		  function
+		  | { part_content = `Filesystem fs; part_dev = dev } ->
+		      f dom ~disk ~partno:(i+1) dev fs
+		  | _ -> ()
+	      ) partitions.parts
+	  | _ -> ()
+	) disks;
+	(* LV filesystems. *)
+	List.iter (fun ({lv_dev = dev}, fs) -> f dom dev fs) filesystems
+    ) doms
+  in
+
+  (* Print stats for each recognized filesystem. *)
+  let print_stats dom ?disk ?partno dev fs =
+    (* Printable name is like "domain:hda" or "domain:hda1". *)
+    let name =
+      let dom_name = dom.dom_name in
+      (* Get the disk name (eg. "hda") from the domain XML, if
+       * we have it, otherwise use the device name (eg. for LVM).
+       *)
+      let disk_name =
+	match disk with
+	| None -> dev#name
+	| Some disk -> disk.d_target
+      in
+      match partno with
+      | None ->
+	  dom_name ^ ":" ^ disk_name
+      | Some partno ->
+	  dom_name ^ ":" ^ disk_name ^ string_of_int partno in
+    printf "%-20s " name;
+
+    if fs.fs_is_swap then (
+      (* Swap partition. *)
+      if not !human then
+	printf "%10Ld                       %s\n"
+	  (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name
+      else
+	printf "%10s                       %s\n"
+	  (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name
+    ) else (
+      (* Ordinary filesystem. *)
+      if not !inodes then (		(* Block display. *)
+	(* 'df' doesn't count the restricted blocks. *)
+	let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
+	let blocks_avail = fs.fs_blocks_avail -^ fs.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 *^ fs.fs_block_size /^ 1024L)
+	    (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L)
+	    (blocks_avail *^ fs.fs_block_size /^ 1024L)
+	    fs.fs_name
+	) else (			(* Human-readable blocks. *)
+	  printf "%10s %10s %10s %s\n"
+	    (printable_size (blocks_total *^ fs.fs_block_size))
+	    (printable_size (fs.fs_blocks_used *^ fs.fs_block_size))
+	    (printable_size (blocks_avail *^ fs.fs_block_size))
+	    fs.fs_name
+	)
+      ) else (				(* Inodes display. *)
+	printf "%10Ld %10Ld %10Ld %s\n"
+	  fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail
+	  fs.fs_name
+      )
+    )
+  in
+  iter_over_filesystems doms print_stats