diff options
Diffstat (limited to 'virt-df/virt_df_main.ml')
| -rw-r--r-- | virt-df/virt_df_main.ml | 488 |
1 files changed, 0 insertions, 488 deletions
diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml deleted file mode 100644 index 65d1f2f..0000000 --- a/virt-df/virt_df_main.ml +++ /dev/null @@ -1,488 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007 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 - -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 |