-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 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 file = source_file_of children in
- let dev = target_dev_of children in
-
- Some {
- d_type = typ; d_device = device; d_file = file; d_dev = dev
+(* 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 unit (* 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. *)
+}
+
+(* 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 filesystems. Returns [Some fs] or [None]. *)
+let probe_for_filesystems 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 =
+ lvm_types := (lvm_name, probe_fn) :: !lvm_types
+*)
+
+(*----------------------------------------------------------------------*)
+
+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 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)";
+ "-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 }
+ ) 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;