(* 'df' command for virtual domains.
- * $Id$
+ (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
+let debug = true (* If true emit lots of debugging information. *)
+
+let ( +* ) = Int32.add
+let ( -* ) = Int32.sub
+let ( ** ) = Int32.mul
+let ( /* ) = Int32.div
+
+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
+let test_files = ref []
+
+class virtual device =
+object (self)
+ method virtual read : int64 -> int -> string
+ method virtual size : int64
+ method virtual name : string
+
+ (* Helper method to read a chunk of data into a bitstring. *)
+ method read_bitstring offset len =
+ let str = self#read offset len in
+ (str, 0, len * 8)
+end
+
+(* A concrete device which just direct-maps a file or /dev device. *)
+class block_device filename =
+ let fd = openfile filename [ O_RDONLY ] 0 in
+ let size = (LargeFile.fstat fd).LargeFile.st_size in
+object (self)
+ inherit device
+ method read offset len =
+ ignore (LargeFile.lseek fd offset SEEK_SET);
+ let str = String.make len '\000' in
+ read fd str 0 len;
+ str
+ method size = size
+ method name = filename
+end
+
+(* The null device. Any attempt to read generates an error. *)
+let null_device : device =
+object
+ inherit device
+ method read _ _ = assert false
+ method size = 0L
+ method name = "null"
+end
-let () =
- (* Command line argument parsing. *)
- let set_uri = function "" -> uri := None | u -> uri := Some u in
-
- let argspec = Arg.align [
- "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)";
- "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)";
- ] in
-
- let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in
- let usage_msg = "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 Unix.geteuid () <> 0 && name = None then (
- print_endline "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
- 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
-
-(* 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. *)
+ dom_lv_filesystems : filesystem list; (* Domain LV filesystems. *)
}
and disk = {
+ (* From the XML ... *)
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=...> *)
+ d_device : string; (* The <disk device=...> (eg "disk") *)
+ d_source : string; (* The <source file=... or dev> *)
+ d_target : string; (* The <target dev=...> (eg "hda") *)
+
+ (* About the device itself. *)
+ d_dev : device; (* Disk device. *)
+ d_content : disk_content; (* What's on it. *)
+}
+and disk_content =
+ [ `Unknown (* Not probed or unknown. *)
+ | `Partitions of partitions (* Contains partitions. *)
+ | `Filesystem of filesystem (* Contains a filesystem directly. *)
+ | `PhysicalVolume of pv (* Contains an LVM PV. *)
+ ]
+
+(* Partitions. *)
+
+and partitions = {
+ parts_name : string; (* Name of partitioning scheme. *)
+ parts : partition list (* Partitions. *)
+}
+and partition = {
+ part_status : partition_status; (* Bootable, etc. *)
+ part_type : int; (* Partition filesystem type. *)
+ part_dev : device; (* Partition device. *)
+ part_content : partition_content; (* What's on it. *)
+}
+and partition_status = Bootable | Nonbootable | Malformed | NullEntry
+and partition_content =
+ [ `Unknown (* Not probed or unknown. *)
+ | `Filesystem of filesystem (* Filesystem. *)
+ | `PhysicalVolume of pv (* Contains an LVM PV. *)
+ ]
+
+(* Filesystems (also swap devices). *)
+and filesystem = {
+ fs_name : string; (* Name of filesystem. *)
+ fs_block_size : int64; (* Block size (bytes). *)
+ fs_blocks_total : int64; (* Total blocks. *)
+ fs_is_swap : bool; (* If swap, following not valid. *)
+ 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. *)
+}
+
+(* Physical volumes. *)
+and pv = {
+ lvm_plugin_id : lvm_plugin_id; (* The LVM plug-in. *)
+ pv_uuid : string; (* UUID. *)
+}
+
+(* Logical volumes. *)
+and lv = {
+ lv_dev : device; (* Logical volume device. *)
}
-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 "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 "get_xml_desc returned no <name> node in XML"
- | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
- | Xml.Element ("name", _, _) :: _ ->
- failwith "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
-
-(* Print the domains / devices. *)
-let () =
- List.iter (
- fun { dom_name = dom_name; dom_disks = dom_disks } ->
- printf "%s:\n" dom_name;
- List.iter (
- function
- | { d_source = Some source; d_target = Some target } ->
- printf "\t%s -> %s\n" source target
- | { d_type = None; d_device = Some "cdrom";
- d_source = None; d_target = Some target } ->
- printf "\t[CD] -> %s\n" target
- | _ ->
- printf "\t(device omitted, missing <source> or <target> in XML\n";
- ) dom_disks
- ) doms
+and lvm_plugin_id = string
+
+(* Convert partition, filesystem types to printable strings for debugging. *)
+let string_of_partition
+ { part_status = status; part_type = typ; part_dev = dev } =
+ sprintf "%s: %s partition type %d"
+ dev#name
+ (match status with
+ | Bootable -> "bootable"
+ | Nonbootable -> "nonbootable"
+ | Malformed -> "malformed"
+ | NullEntry -> "empty")
+ typ
+
+let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
+ if not swap then name
+ else name ^ " [swap]"
+
+(* Register a partition scheme. *)
+let partition_types = ref []
+let partition_type_register (parts_name : string) probe_fn =
+ partition_types := (parts_name, probe_fn) :: !partition_types
+
+(* Probe a device for partitions. Returns [Some parts] or [None]. *)
+let probe_for_partitions dev =
+ if debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
+ let rec loop = function
+ | [] -> None
+ | (parts_name, probe_fn) :: rest ->
+ try Some (probe_fn dev)
+ with Not_found -> loop rest
+ in
+ let r = loop !partition_types in
+ if debug then (
+ match r with
+ | None -> eprintf "no partitions found on %s\n%!" dev#name
+ | Some { parts_name = name; parts = parts } ->
+ eprintf "found %d %s partitions on %s:\n"
+ (List.length parts) name dev#name;
+ List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
+ );
+ r
+
+(* Register a filesystem type (or swap). *)
+let filesystem_types = ref []
+let filesystem_type_register (fs_name : string) probe_fn =
+ filesystem_types := (fs_name, probe_fn) :: !filesystem_types
+
+(* Probe a device for a filesystem. Returns [Some fs] or [None]. *)
+let probe_for_filesystem dev =
+ if debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
+ let rec loop = function
+ | [] -> None
+ | (fs_name, probe_fn) :: rest ->
+ try Some (probe_fn dev)
+ with Not_found -> loop rest
+ in
+ let r = loop !filesystem_types in
+ if debug then (
+ match r with
+ | None -> eprintf "no filesystem found on %s\n%!" dev#name
+ | Some fs ->
+ eprintf "found a filesystem on %s:\n" dev#name;
+ eprintf "\t%s\n%!" (string_of_filesystem fs)
+ );
+ r
+
+(* Register a volume management type. *)
+let lvm_types = ref []
+let lvm_type_register (lvm_name : string) probe_fn list_lvs_fn =
+ lvm_types := (lvm_name, (probe_fn, list_lvs_fn)) :: !lvm_types
+
+(* Probe a device for a PV. Returns [Some lvm_name] or [None]. *)
+let probe_for_pv dev =
+ if debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
+ let rec loop = function
+ | [] -> None
+ | (lvm_name, (probe_fn, _)) :: rest ->
+ try Some (probe_fn lvm_name dev)
+ with Not_found -> loop rest
+ in
+ let r = loop !lvm_types in
+ if debug then (
+ match r with
+ | None -> eprintf "no PV found on %s\n%!" dev#name
+ | Some { lvm_plugin_id = name } ->
+ eprintf "%s contains a %s PV\n%!" dev#name name
+ );
+ r
+
+let list_lvs lvm_name devs =
+ let _, list_lvs_fn = List.assoc lvm_name !lvm_types in
+ list_lvs_fn devs
+
+(*----------------------------------------------------------------------*)
+
+(* This version by Isaac Trotts. *)
+let group_by ?(cmp = Pervasives.compare) ls =
+ let ls' =
+ List.fold_left
+ (fun acc (day1, x1) ->
+ match acc with
+ [] -> [day1, [x1]]
+ | (day2, ls2) :: acctl ->
+ if cmp day1 day2 = 0
+ then (day1, x1 :: ls2) :: acctl
+ else (day1, [x1]) :: acc)
+ []
+ ls
+ in
+ let ls' = List.rev ls' in
+ List.map (fun (x, xs) -> x, List.rev xs) ls'
git.annexia.org / virt-top.git / blobdiff