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
+(* If set to true, then emit lots of debugging information. *)
+let debug = true
-let uri = ref None
-let inodes = ref false
-let human = ref false
-let all = ref false
+(* Int32 infix operators for convenience. *)
+let ( +* ) = Int32.add
+let ( -* ) = Int32.sub
+let ( ** ) = Int32.mul
+let ( /* ) = Int32.div
-(* Maximum number of extended partitions possible. *)
-let max_extended_partitions = 100
+(* Int64 infix operators for convenience. *)
+let ( +^ ) = Int64.add
+let ( -^ ) = Int64.sub
+let ( *^ ) = Int64.mul
+let ( /^ ) = Int64.div
+
+(* State of command line arguments. *)
+let uri = ref None (* Hypervisor/libvirt URI. *)
+let inodes = ref false (* Display inodes. *)
+let human = ref false (* Display human-readable. *)
+let all = ref false (* Show all/active domains. *)
+let test_files = ref [] (* Used for test mode only. *)
+
+(*----------------------------------------------------------------------*)
+(* The "domain/device model" that we currently understand looks
+ * like this:
+ *
+ * domains
+ * |
+ * \--- host partitions / disk image files
+ * ||
+ * guest block devices
+ * |
+ * +--> guest partitions (eg. using MBR)
+ * | |
+ * \-(1)->+--- filesystems (eg. ext3)
+ * |
+ * \--- PVs for LVM
+ * |||
+ * VGs and LVs
+ *
+ * (1) Filesystems and PVs may also appear directly on guest
+ * block devices.
+ *
+ * Partition schemes (eg. MBR) and filesystems register themselves
+ * with this main module and they are queried first to get an idea
+ * of the physical devices, partitions and filesystems potentially
+ * available to the guest.
+ *
+ * Volume management schemes (eg. LVM) register themselves here
+ * and are called later with "spare" physical devices and partitions
+ * to see if they contain LVM data. If this results in additional
+ * logical volumes then these are checked for filesystems.
+ *
+ * Swap space is considered to be a dumb filesystem for the purposes
+ * of this discussion.
+ *)
-let sector_size = 512L
+(* A virtual (or physical!) device, encapsulating any translation
+ * that has to be done to access the device. eg. For partitions
+ * there is a simple offset, but for LVM you may need complicated
+ * table lookups.
+ *
+ * We keep the underlying file descriptors open for the duration
+ * of the program. There aren't likely to be many of them, and
+ * the program is short-lived, and it's easier than trying to
+ * track which device is using what fd. As a result, there is no
+ * need for any close/deallocation function.
+ *
+ * Note the very rare use of OOP in OCaml!
+ *)
+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
+
+(* A 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
+
+(* Domains and candidate guest block devices. *)
-(* 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 = {
+ (* 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") *)
-type partition = {
+ (* 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 unit (* 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 type. *)
- part_lba_start : int64; (* LBA start sector. *)
- part_len : int64; (* Length in sectors. *)
+ 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
-
-type filesystem_stats = {
- fs_name : string;
+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_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])
+(* 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. *)
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)";
" " ^ 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
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 =
+ 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 ("devices", _, devices) -> Some devices
+ | 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
- ) 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
+ ) 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;
+ }
+ ]
+ }
+ ) !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_filesystems dev in
+ match fs with
+ | Some fs ->
+ { disk with d_content = `Filesystem fs }
+ | None ->
+ (* Not partitioned, no filesystem, so it's spare. *)
+ disk
+ ) 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_filesystems p.part_dev in
+ match fs with
+ | Some fs ->
+ { p with part_content = `Filesystem fs }
+ | None ->
+ p
+ ) else p
+ ) parts.parts in
+ let parts = { parts with parts = ps } in
+ { disk with d_content = `Partitions parts }
+ | disk -> disk
+ ) in
+
+ (* XXX LVM stuff here. *)
+
+
(* Print the title. *)
let () =
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
+ 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 =
+ List.iter (
+ fun ({ dom_disks = disks } as dom) ->
+ List.iter (
+ function
+ | ({ d_content = `Filesystem fs } as disk) ->
+ f dom disk None fs
+ | ({ d_content = `Partitions partitions } as disk) ->
+ List.iteri (
+ fun i ->
+ function
+ | ({ part_content = `Filesystem fs } as part) ->
+ f dom disk (Some (part, i)) fs
+ | _ -> ()
+ ) partitions.parts
+ | _ -> ()
+ ) disks
+ ) doms
+ in
+
+ (* Print stats for each recognized filesystem. *)
+ let print_stats dom disk part fs =
+ (* Printable name is like "domain:hda" or "domain:hda1". *)
+ let name =
+ let dom_name = dom.dom_name in
+ let d_target = disk.d_target in
+ match part with
+ | None ->
+ dom_name ^ ":" ^ d_target
+ | Some (_, pnum) ->
+ dom_name ^ ":" ^ d_target ^ string_of_int pnum 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
+
+(*
+(* 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)
+*)
git.annexia.org / virt-top.git / blobdiff