-virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmo \
+virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmi \
/usr/lib64/ocaml/bitmatch/bitmatch.cmi
virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx \
/usr/lib64/ocaml/bitmatch/bitmatch.cmi
-virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmo \
+virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmi \
/usr/lib64/ocaml/bitmatch/bitmatch.cmi
virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \
/usr/lib64/ocaml/bitmatch/bitmatch.cmi
-virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmo
+virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmi
virt_df_lvm2.cmx: virt_df_gettext.cmx virt_df.cmx
-virt_df_main.cmo: virt_df.cmo
-virt_df_main.cmx: virt_df.cmx
-virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmo \
+virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi \
+ ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi
+virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx \
+ ../libvirt/libvirt_version.cmx ../libvirt/libvirt.cmx
+virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmi \
/usr/lib64/ocaml/bitmatch/bitmatch.cmi
virt_df_mbr.cmx: virt_df_gettext.cmx virt_df.cmx \
/usr/lib64/ocaml/bitmatch/bitmatch.cmi
-virt_df.cmo: virt_df_gettext.cmo ../libvirt/libvirt_version.cmi \
- ../libvirt/libvirt.cmi
-virt_df.cmx: virt_df_gettext.cmx ../libvirt/libvirt_version.cmx \
- ../libvirt/libvirt.cmx
+virt_df.cmo: virt_df_gettext.cmo virt_df.cmi
+virt_df.cmx: virt_df_gettext.cmx virt_df.cmi
open Virt_df_gettext.Gettext
-module C = Libvirt.Connect
-module D = Libvirt.Domain
+let debug = true (* If true emit lots of debugging information. *)
-(* If set to true, then emit lots of debugging information. *)
-let debug = true
-
-(* Int32 infix operators for convenience. *)
let ( +* ) = Int32.add
let ( -* ) = Int32.sub
let ( ** ) = Int32.mul
let ( /* ) = Int32.div
-(* 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 uri = ref None
+let inodes = ref false
+let human = ref false
+let all = ref false
+let test_files = ref []
-(* 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 name = filename
end
-(* A null device. Any attempt to read generates an error. *)
+(* The null device. Any attempt to read generates an error. *)
let null_device : device =
object
inherit device
method name = "null"
end
-(* Domains and candidate guest block devices. *)
-
type domain = {
dom_name : string; (* Domain name. *)
dom_id : int option; (* Domain ID (if running). *)
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;
- }
- ]
- }
- ) !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 () =
- 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 =
- 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)
-*)
--- /dev/null
+(** '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.
+ *)
+
+(* This module (Virt_df) contains functions and values which are
+ * used throughout the plug-ins and main code.
+ *)
+
+val debug : bool
+(** If true, emit logs of debugging information to stderr. *)
+
+val ( +* ) : int32 -> int32 -> int32
+val ( -* ) : int32 -> int32 -> int32
+val ( ** ) : int32 -> int32 -> int32
+val ( /* ) : int32 -> int32 -> int32
+val ( +^ ) : int64 -> int64 -> int64
+val ( -^ ) : int64 -> int64 -> int64
+val ( *^ ) : int64 -> int64 -> int64
+val ( /^ ) : int64 -> int64 -> int64
+(** int32 and int64 infix operators for convenience. *)
+
+val uri : string option ref (** Hypervisor/libvirt URI. *)
+val inodes : bool ref (** Display inodes. *)
+val human : bool ref (** Display human-readable. *)
+val all : bool ref (** Show all or just active domains. *)
+val test_files : string list ref (** In test mode (-t) list of files. *)
+(** State of command line arguments. *)
+
+(**
+ {2 Domain/device model}
+
+ The "domain/device model" that we currently understand looks
+ like this:
+
+{v
+domains
+ |
+ \--- host partitions / disk image files
+ ||
+ guest block devices
+ |
+ +--> guest partitions (eg. using MBR)
+ | |
+ \-(1)->+--- filesystems (eg. ext3)
+ |
+ \--- PVs for LVM
+ |||
+ VGs and LVs
+v}
+
+ (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.
+*)
+
+class virtual device :
+ object
+ method virtual name : string
+ method virtual read : int64 -> int -> string
+ method read_bitstring : int64 -> int -> string * int * int
+ method virtual size : int64
+ end
+ (**
+ 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 block_device :
+ string ->
+ object
+ method name : string
+ method read : int64 -> int -> string
+ method read_bitstring : int64 -> int -> string * int * int
+ method size : int64
+ end
+ (** A concrete device which just direct-maps a file or /dev device. *)
+
+val null_device : device
+ (** The null device. Any attempt to read generates an error. *)
+
+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; (** The <disk device=...> (eg "disk") *)
+ d_source : string; (** The <source file=... or dev> *)
+ d_target : string; (** The <target dev=...> (eg "hda") *)
+ d_dev : device; (** Disk device. *)
+ d_content : disk_content; (** What's on it. *)
+}
+and disk_content =
+ [ `Filesystem of filesystem (** Contains a direct filesystem. *)
+ | `Partitions of partitions (** Contains partitions. *)
+ | `PhysicalVolume of unit (** Contains an LVM PV. *)
+ | `Unknown (** Not probed or unknown. *)
+ ]
+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 =
+ [ `Filesystem of filesystem (** Filesystem. *)
+ | `PhysicalVolume of unit (** Contains an LVM PV. *)
+ | `Unknown (** Not probed or unknown. *)
+ ]
+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. *)
+}
+
+val string_of_partition : partition -> string
+val string_of_filesystem : filesystem -> string
+(** Convert a partition or filesystem struct to a string (for debugging). *)
+
+val partition_type_register : string -> (device -> partitions) -> unit
+(** Register a partition probing plugin. *)
+
+val probe_for_partitions : device -> partitions option
+(** Do a partition probe on a device. Returns [Some partitions] or [None]. *)
+
+val filesystem_type_register : string -> (device -> filesystem) -> unit
+(** Register a filesystem probing plugin. *)
+
+val probe_for_filesystems : device -> filesystem option
+(** Do a filesystem probe on a device. Returns [Some filesystem] or [None]. *)
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)
-(* We just need this so that the filesystem modules get a chance to
- * register themselves before we run the main program.
- *)
-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)";
+ "-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;
+ }
+ ]
+ }
+ ) !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 () =
+ 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 =
+ 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
git.annexia.org / virt-top.git / commitdiff