From 9611aba66734efe3e2f1e0792a90003b657a89f5 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Thu, 1 Jan 1970 00:00:00 +0000 Subject: [PATCH] Reorganize the code so disk parsing is in a separate library. --- .hgignore | 6 +- Makefile.in | 5 +- configure.ac | 3 +- lib/.depend | 35 +++ lib/Makefile.in | 89 ++++++ lib/README | 72 +++++ lib/diskimage.ml | 226 +++++++++++++++ lib/diskimage.mli | 223 ++++++++++++++ virt-df/virt_df_ext2.ml => lib/diskimage_ext2.ml | 8 +- virt-df/virt_df_lvm2.mli => lib/diskimage_ext2.mli | 6 +- .../diskimage_linux_swap.ml | 8 +- .../diskimage_linux_swap.mli | 6 +- virt-df/virt_df_lvm2.ml => lib/diskimage_lvm2.ml | 13 +- .../diskimage_lvm2.mli | 9 +- .../diskimage_lvm2_lexer.mll | 4 +- .../diskimage_lvm2_metadata.ml | 0 .../diskimage_lvm2_metadata.mli | 0 .../diskimage_lvm2_parser.mly | 4 +- virt-df/virt_df_mbr.ml => lib/diskimage_mbr.ml | 6 +- virt-df/virt_df_mbr.mli => lib/diskimage_mbr.mli | 6 +- lib/diskimage_utils.ml | 204 +++++++++++++ lib/diskimage_utils.mli | 141 +++++++++ virt-df/.depend | 25 +- virt-df/Makefile.in | 36 +-- virt-df/README | 59 +--- virt-df/virt_df.ml | 263 ----------------- virt-df/virt_df.mli | 207 ------------- virt-df/virt_df_csv.ml | 2 +- virt-df/virt_df_main.ml | 319 +++++++-------------- 29 files changed, 1146 insertions(+), 839 deletions(-) create mode 100644 lib/.depend create mode 100644 lib/Makefile.in create mode 100644 lib/README create mode 100644 lib/diskimage.ml create mode 100644 lib/diskimage.mli rename virt-df/virt_df_ext2.ml => lib/diskimage_ext2.ml (97%) rename virt-df/virt_df_lvm2.mli => lib/diskimage_ext2.mli (88%) rename virt-df/virt_df_linux_swap.ml => lib/diskimage_linux_swap.ml (90%) rename virt-df/virt_df_ext2.mli => lib/diskimage_linux_swap.mli (88%) rename virt-df/virt_df_lvm2.ml => lib/diskimage_lvm2.ml (97%) rename virt-df/virt_df_linux_swap.mli => lib/diskimage_lvm2.mli (82%) rename virt-df/virt_df_lvm2_lexer.mll => lib/diskimage_lvm2_lexer.mll (98%) rename virt-df/virt_df_lvm2_metadata.ml => lib/diskimage_lvm2_metadata.ml (100%) rename virt-df/virt_df_lvm2_metadata.mli => lib/diskimage_lvm2_metadata.mli (100%) rename virt-df/virt_df_lvm2_parser.mly => lib/diskimage_lvm2_parser.mly (95%) rename virt-df/virt_df_mbr.ml => lib/diskimage_mbr.ml (97%) rename virt-df/virt_df_mbr.mli => lib/diskimage_mbr.mli (88%) create mode 100644 lib/diskimage_utils.ml create mode 100644 lib/diskimage_utils.mli diff --git a/.hgignore b/.hgignore index 4c319f9..0fb9d1b 100644 --- a/.hgignore +++ b/.hgignore @@ -31,6 +31,6 @@ wininstaller.nsis virt-df/virt_df_gettext.ml po/*.mo po/*.po.bak -virt-df/virt_df_lvm2_lexer.ml -virt-df/virt_df_lvm2_parser.ml -virt-df/virt_df_lvm2_parser.mli \ No newline at end of file +lib/diskimage_lvm2_lexer.ml +lib/diskimage_lvm2_parser.ml +lib/diskimage_lvm2_parser.mli \ No newline at end of file diff --git a/Makefile.in b/Makefile.in index 24bb596..2211d32 100644 --- a/Makefile.in +++ b/Makefile.in @@ -20,7 +20,7 @@ VERSION = @PACKAGE_VERSION@ INSTALL = @INSTALL@ -SUBDIRS = virt-df +SUBDIRS = lib virt-df all opt depend install: for d in $(SUBDIRS); do \ @@ -30,7 +30,8 @@ all opt depend install: clean: for d in . $(SUBDIRS); do \ - (cd $$d; rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so *.opt *~ *.dll *.exe core); \ + (cd $$d; rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a \ + *.so *.opt *~ *.dll *.exe core); \ done rm -f virt-df/virt-df diff --git a/configure.ac b/configure.ac index f875ffa..33cd4c6 100644 --- a/configure.ac +++ b/configure.ac @@ -17,7 +17,7 @@ dnl Process this file with autoconf to produce a configure script. -AC_INIT(virt-df,2.0.0) +AC_INIT(virt-df,2.0.1) AC_PROG_INSTALL @@ -120,6 +120,7 @@ dnl Produce output files. AC_CONFIG_HEADERS([config.h]) AC_CONFIG_FILES([Makefile Make.rules + lib/Makefile po/Makefile virt-df/Makefile ]) diff --git a/lib/.depend b/lib/.depend new file mode 100644 index 0000000..a2677bf --- /dev/null +++ b/lib/.depend @@ -0,0 +1,35 @@ +diskimage_ext2.cmi: diskimage_utils.cmi +diskimage_linux_swap.cmi: diskimage_utils.cmi +diskimage_lvm2.cmi: diskimage_utils.cmi +diskimage_lvm2_parser.cmi: diskimage_lvm2_metadata.cmi +diskimage_mbr.cmi: diskimage_utils.cmi +diskimage.cmi: /usr/lib64/ocaml/bitmatch/bitmatch.cmi +diskimage_utils.cmi: /usr/lib64/ocaml/bitmatch/bitmatch.cmi +diskimage_ext2.cmo: diskimage_utils.cmi \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_ext2.cmi +diskimage_ext2.cmx: diskimage_utils.cmx \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_ext2.cmi +diskimage_linux_swap.cmo: diskimage_utils.cmi \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_linux_swap.cmi +diskimage_linux_swap.cmx: diskimage_utils.cmx \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_linux_swap.cmi +diskimage_lvm2_metadata.cmo: diskimage_lvm2_metadata.cmi +diskimage_lvm2_metadata.cmx: diskimage_lvm2_metadata.cmi +diskimage_lvm2.cmo: diskimage_utils.cmi diskimage_lvm2_metadata.cmi \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_lvm2.cmi +diskimage_lvm2.cmx: diskimage_utils.cmx diskimage_lvm2_metadata.cmx \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_lvm2.cmi +diskimage_lvm2_parser.cmo: diskimage_lvm2_metadata.cmi \ + diskimage_lvm2_parser.cmi +diskimage_lvm2_parser.cmx: diskimage_lvm2_metadata.cmx \ + diskimage_lvm2_parser.cmi +diskimage_mbr.cmo: diskimage_utils.cmi /usr/lib64/ocaml/bitmatch/bitmatch.cmi \ + diskimage_mbr.cmi +diskimage_mbr.cmx: diskimage_utils.cmx /usr/lib64/ocaml/bitmatch/bitmatch.cmi \ + diskimage_mbr.cmi +diskimage.cmo: diskimage_utils.cmi diskimage_mbr.cmi diskimage_lvm2.cmi \ + diskimage_linux_swap.cmi diskimage_ext2.cmi diskimage.cmi +diskimage.cmx: diskimage_utils.cmx diskimage_mbr.cmx diskimage_lvm2.cmx \ + diskimage_linux_swap.cmx diskimage_ext2.cmx diskimage.cmi +diskimage_utils.cmo: diskimage_utils.cmi +diskimage_utils.cmx: diskimage_utils.cmi diff --git a/lib/Makefile.in b/lib/Makefile.in new file mode 100644 index 0000000..ec2a62b --- /dev/null +++ b/lib/Makefile.in @@ -0,0 +1,89 @@ +# virt-df +# Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones +# +# 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. + +PACKAGE := @PACKAGE_NAME@ +VERSION := @PACKAGE_VERSION@ + +INSTALL := @INSTALL@ +HAVE_PERLDOC := @HAVE_PERLDOC@ + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +bindir = @bindir@ + +#OCAMLCPACKAGES := -package unix,extlib,bitmatch +OCAMLCPACKAGES := -package unix,extlib -I +bitmatch + +#---------------------------------------------------------------------- +# Build up the list of object files. + +OBJS := diskimage_utils.cmo + +# Plugin objects. +OBJS += diskimage_ext2.cmo \ + diskimage_linux_swap.cmo \ + diskimage_lvm2_metadata.cmo \ + diskimage_lvm2_parser.cmo \ + diskimage_lvm2_lexer.cmo \ + diskimage_lvm2.cmo \ + diskimage_mbr.cmo + +OBJS += diskimage.cmo + +XOBJS := $(OBJS:.cmo=.cmx) + +#---------------------------------------------------------------------- + +SYNTAX := -pp "camlp4o -I`ocamlc -where`/bitmatch pa_bitmatch.cmo" + +OCAMLCFLAGS := -g -w s $(SYNTAX) +#OCAMLCLIBS := -linkpkg +OCAMLCLIBS := -linkpkg bitmatch.cma + +OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) +OCAMLOPTFLAGS := -w s $(SYNTAX) +#OCAMLOPTLIBS := $(OCAMLCLIBS) +OCAMLOPTLIBS := -linkpkg bitmatch.cmxa + +OCAMLDEPFLAGS := $(SYNTAX) + +BYTE_TARGETS := diskimage.cma +OPT_TARGETS := diskimage.cmxa + +all: $(BYTE_TARGETS) + +opt: $(OPT_TARGETS) + +diskimage.cma: $(OBJS) + ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ + -a -o $@ $^ + +diskimage.cmxa: $(XOBJS) + ocamlfind ocamlopt \ + $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ + -a -o $@ $^ + +# 'make depend' doesn't catch these dependencies because the .mli file +# is auto-generated. +diskimage_lvm2_parser.cmo: diskimage_lvm2_parser.cmi +diskimage_lvm2_parser.cmx: diskimage_lvm2_parser.cmi +diskimage_lvm2_parser.cmi: diskimage_lvm2_parser.mli + +install: + ocamlfind install diskimage *.mli *.cma *.cmx *.cmxa *.a + +include ../Make.rules diff --git a/lib/README b/lib/README new file mode 100644 index 0000000..6ee34fc --- /dev/null +++ b/lib/README @@ -0,0 +1,72 @@ +For user documentation: + +Please see the manual page (virt-df.pod or virt-df.txt in this +directory). + +Developer documentation +---------------------------------------------------------------------- + +This subdirectory contains a library of useful functions for parsing +disk images. + +It is all based on and uses the pa_bitmatch syntax extension & +library. You need pa_bitmatch >= 0.5. + +This program has suddenly become rather large and confusing. +Hopefully this documentation should go some way towards explaining +what is going on inside the source. + +The main program consists of two modules: + + - diskimage.ml / diskimage.mli (module name: Diskimage) + + This has evolved into a library of miscellaneous functions + and values which are included throughout the rest of the + program. If you see an unexplained function then it's + likely that it is defined in here. + + Start by reading diskimage.mli which contains the full types + and plenty of documentation. + + - diskimage_main.ml + + This is the program. It reads the command line arguments, + loads the domain descriptions, calls out to the plug-ins + to probe for disks / partitions / filesystems / etc., and + finally prints the results. + + The file consists of basically one large program that + does all of the above in sequence. + +Everything else in this directory is a plug-in specialized for probing +a particular filesystem, partition scheme or type of LVM. The +plug-ins at time of writing are: + + - diskimage_ext2.ml / diskimage_ext2.mli + + EXT2/3/4 plug-in. + + - diskimage_linux_swap.ml / diskimage_linux_swap.mli + + Linux swap (new style) plug-in. + + - diskimage_mbr.ml / diskimage_mbr.mli + + Master Boot Record (MS-DOS) disk partitioning plug-in. + + - diskimage_lvm2* + + LVM2 parsing, which is by far the most complex plug-in. + It consists of: + + - diskimage_lvm2.ml + - diskimage_lvm2.mli + LVM2 probing, PV detection. + + - diskimage_lvm2_parser.mly + - diskimage_lvm2_lexer.mll + Scanner/parser for parsing LVM2 metadata definitions. + + - diskimage_lvm2_metadata.ml + - diskimage_lvm2_metadata.mli + AST for LVM2 metadata definitions. diff --git a/lib/diskimage.ml b/lib/diskimage.ml new file mode 100644 index 0000000..fbbec4b --- /dev/null +++ b/lib/diskimage.ml @@ -0,0 +1,226 @@ +(* Diskimage library for reading disk images. + (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 + +include Diskimage_utils + +let partition_types = [ + "MBR", Diskimage_mbr.probe_mbr; +] + +let filesystem_types = [ + "ext2", Diskimage_ext2.probe_ext2; + "linux_swap", Diskimage_linux_swap.probe_swap; +] + +let lvm_types = [ + "LVM", (Diskimage_lvm2.probe_pv, Diskimage_lvm2.list_lvs); +] + +(* 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 + +(* 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 + +(* 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 + +(* Create machine description. *) +let open_machine name disks = + let disks = List.map ( + fun (name, path) -> + let dev = new block_device path in + { d_name = name; d_dev = dev; d_content = `Unknown } + ) disks in + { m_name = name; m_disks = disks; m_lv_filesystems = [] } + +let close_machine { m_disks = m_disks } = + (* Only close the disks, assume all other devices are derived from them. *) + List.iter (fun { d_dev = d_dev } -> d_dev#close ()) m_disks + +let scan_machine ({ m_disks = m_disks } as machine) = + let m_disks = List.map ( + 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. *) + ) m_disks in + + (* Now we have either detected partitions or a filesystem on each + * physical device (or perhaps neither). See what is on those + * partitions. + *) + let m_disks = List.map ( + 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 + ) m_disks in + + (* LVM filesystem detection + * + * 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. + * 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 + ) m_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 + | _ -> [] + ) m_disks in + let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in + + (* Second: filesystem on LV detection. + * 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 + + { machine with + m_disks = m_disks; + m_lv_filesystems = filesystems } diff --git a/lib/diskimage.mli b/lib/diskimage.mli new file mode 100644 index 0000000..b0ecd8d --- /dev/null +++ b/lib/diskimage.mli @@ -0,0 +1,223 @@ +(** Diskimage library for reading disk images. *) +(* (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. + *) + +(** + {2 Machine/device model} + + The "machine/device model" that we currently understand looks + like this: + +{v +machines + | + \--- 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. LVM2) 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 + (** Return some printable name for the device. *) + method virtual size : int64 + (** Return the size of the device in bytes. + + Note: For some types of devices, the device may have + "holes", alignment requirements, etc. so this method doesn't + imply that every byte from [0..size-1] is readable. *) + method close : unit -> unit + (** Close the device. This must be called to fully free up + any resources used by the device. *) + method virtual read : int64 -> int -> string + (** [read offset len] reads len bytes starting at offset. *) + method read_bitstring : int64 -> int -> Bitmatch.bitstring + (** [read_bitstring] is the same as [read] but returns + a pa_bitmatch-style bitstring. *) + 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. + + Note this very rare use of OOP in OCaml! + *) + +class block_device : string -> + object + method name : string + method size : int64 + method close : unit -> unit + method read : int64 -> int -> string + method read_bitstring : int64 -> int -> Bitmatch.bitstring + end + (** A concrete device which just direct-maps a file or /dev device. *) + +class offset_device : string -> int64 -> int64 -> device -> + object + method name : string + method size : int64 + method close : unit -> unit + method read : int64 -> int -> string + method read_bitstring : int64 -> int -> Bitmatch.bitstring + end + (** A concrete device which maps a linear part of an underlying device. + + [new offset_device name start size dev] creates a new + device which maps bytes from [start] to [start+size-1] + of the underlying device [dev] (ie. in this device they + appear as bytes [0] to [size-1]). + + Useful for things like partitions. + *) + +val null_device : device + (** The null device. Any attempt to read generates an error. *) + +type machine = { + m_name : string; (** Machine name. *) + m_disks : disk list; (** Machine disks. *) + m_lv_filesystems : + (lv * filesystem) list; (** Machine LV filesystems. *) +} + (** A 'machine' is just a convenient holder for collections of disks. *) + +and disk = { + d_name : string; (** Device name (eg "hda") *) + d_dev : device; (** Disk device. *) + d_content : disk_content; (** What's on it. *) +} + (** A single physical disk image. *) + +and disk_content = + [ `Filesystem of filesystem (** Contains a direct filesystem. *) + | `Partitions of partitions (** Contains partitions. *) + | `PhysicalVolume of pv (** 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. *) +} + (** Partitions as found on a disk image. *) + +and partition_status = Bootable | Nonbootable | Malformed | NullEntry +and partition_content = + [ `Filesystem of filesystem (** Filesystem. *) + | `PhysicalVolume of pv (** 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. *) +} + (** A filesystem. *) + +and pv = { + lvm_plugin_id : lvm_plugin_id; (** The LVM plug-in which detected + this. *) + pv_uuid : string; (** UUID. *) +} +and lv = { + lv_dev : device; (** Logical volume device. *) +} + (** Physical and logical volumes as used by LVM plug-ins. *) + +and lvm_plugin_id + +val string_of_partition : partition -> string +val string_of_filesystem : filesystem -> string + (** Convert a partition or filesystem struct to a string (for debugging). *) + +(** {2 Scanning functions} *) + +val open_machine : string -> (string * string) list -> machine + (** [open_machine m_name devs] + creates a {!machine} containing the devices listed. + + [devs] is a list of pairs of [(name, path)] elements + where [name] is something like ["hda"] and [path] + is a path to a disk image or [/dev] device. + + This function does not do any scanning, so all disk + contents are just set to [`Unknown] and there are no + LV filesystems in the returned structure. + *) + +val close_machine : machine -> unit + (** This is a convenience function which calls the [dev#close] + method on any open devices owned by the machine. This just + has the effect of closing any file descriptors which are + opened by these devices. + *) + +val scan_machine : machine -> machine + (** This does a complete scan of all devices owned by a machine, + identifying all partitions, filesystems, physical and logical + volumes that are known to this library. + + Returns an updated {!machine} structure with the scan results. + *) + +(** {2 Debugging} *) + +val debug : bool ref + (** If set to true, functions emit debugging information to stderr. *) diff --git a/virt-df/virt_df_ext2.ml b/lib/diskimage_ext2.ml similarity index 97% rename from virt-df/virt_df_ext2.ml rename to lib/diskimage_ext2.ml index f4a550f..0457597 100644 --- a/virt-df/virt_df_ext2.ml +++ b/lib/diskimage_ext2.ml @@ -22,8 +22,7 @@ open Unix open Printf -open Virt_df_gettext.Gettext -open Virt_df +open Diskimage_utils let superblock_offset = 1024L @@ -114,7 +113,7 @@ let probe_ext2 dev = let overhead = (* XXX *) overhead in { - fs_name = s_ "Linux ext2/3"; + fs_name = "Linux ext2/3"; fs_block_size = block_size; fs_blocks_total = Int64.of_int32 s_blocks_count -^ overhead; fs_is_swap = false; @@ -133,6 +132,3 @@ let probe_ext2 dev = | { _ } -> raise Not_found (* Not an EXT2/3 superblock. *) - -(* Register with main code. *) -let () = filesystem_type_register "ext2" probe_ext2 diff --git a/virt-df/virt_df_lvm2.mli b/lib/diskimage_ext2.mli similarity index 88% rename from virt-df/virt_df_lvm2.mli rename to lib/diskimage_ext2.mli index d32a0f8..8d93189 100644 --- a/virt-df/virt_df_lvm2.mli +++ b/lib/diskimage_ext2.mli @@ -17,6 +17,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -(* This file is empty to stop this plug-in from exporting any - symbols to other modules by accident. -*) +(**/**) + +val probe_ext2 : Diskimage_utils.device -> Diskimage_utils.filesystem diff --git a/virt-df/virt_df_linux_swap.ml b/lib/diskimage_linux_swap.ml similarity index 90% rename from virt-df/virt_df_linux_swap.ml rename to lib/diskimage_linux_swap.ml index 0857327..f4af9c2 100644 --- a/virt-df/virt_df_linux_swap.ml +++ b/lib/diskimage_linux_swap.ml @@ -20,8 +20,7 @@ Support for Linux swap partitions. *) -open Virt_df_gettext.Gettext -open Virt_df +open Diskimage_utils let probe_swap dev = (* Load the "superblock" (ie. first 0x1000 bytes). *) @@ -34,7 +33,7 @@ let probe_swap dev = "SWAPSPACE2" : 80 : string } -> { - fs_name = s_ "Linux swap"; + fs_name = "Linux swap"; fs_block_size = 4096L; (* XXX *) fs_blocks_total = dev#size /^ 4096L; @@ -50,6 +49,3 @@ let probe_swap dev = } | { _ } -> raise Not_found (* Not Linux swapspace. *) - -(* Register with main code. *) -let () = filesystem_type_register "linux_swap" probe_swap diff --git a/virt-df/virt_df_ext2.mli b/lib/diskimage_linux_swap.mli similarity index 88% rename from virt-df/virt_df_ext2.mli rename to lib/diskimage_linux_swap.mli index d32a0f8..75bc517 100644 --- a/virt-df/virt_df_ext2.mli +++ b/lib/diskimage_linux_swap.mli @@ -17,6 +17,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -(* This file is empty to stop this plug-in from exporting any - symbols to other modules by accident. -*) +(**/**) + +val probe_swap : Diskimage_utils.device -> Diskimage_utils.filesystem diff --git a/virt-df/virt_df_lvm2.ml b/lib/diskimage_lvm2.ml similarity index 97% rename from virt-df/virt_df_lvm2.ml rename to lib/diskimage_lvm2.ml index 4976497..f8ce5ec 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/lib/diskimage_lvm2.ml @@ -23,10 +23,8 @@ open Printf open ExtList -open Virt_df_gettext.Gettext -open Virt_df - -open Virt_df_lvm2_metadata +open Diskimage_utils +open Diskimage_lvm2_metadata let plugin_name = "LVM2" @@ -188,7 +186,7 @@ let rec list_lvs devs = (* Parse the metadata using the external lexer/parser. *) let pvs = List.map ( fun (uuid, (metadata, dev)) -> - uuid, (Virt_df_lvm2_lexer.parse_lvm2_metadata_from_string metadata, + uuid, (Diskimage_lvm2_lexer.parse_lvm2_metadata_from_string metadata, dev) ) pvs in @@ -430,8 +428,3 @@ let rec list_lvs devs = (* Return the list of LV devices. *) lvs - -(*----------------------------------------------------------------------*) -(* Register with main code. *) -let () = - lvm_type_register plugin_name probe_pv list_lvs diff --git a/virt-df/virt_df_linux_swap.mli b/lib/diskimage_lvm2.mli similarity index 82% rename from virt-df/virt_df_linux_swap.mli rename to lib/diskimage_lvm2.mli index d32a0f8..88e40e4 100644 --- a/virt-df/virt_df_linux_swap.mli +++ b/lib/diskimage_lvm2.mli @@ -17,6 +17,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -(* This file is empty to stop this plug-in from exporting any - symbols to other modules by accident. -*) +(**/**) + +val probe_pv : + Diskimage_utils.lvm_plugin_id -> Diskimage_utils.device -> + Diskimage_utils.pv +val list_lvs : Diskimage_utils.device list -> Diskimage_utils.lv list diff --git a/virt-df/virt_df_lvm2_lexer.mll b/lib/diskimage_lvm2_lexer.mll similarity index 98% rename from virt-df/virt_df_lvm2_lexer.mll rename to lib/diskimage_lvm2_lexer.mll index 2dbe7e5..0a791b2 100644 --- a/virt-df/virt_df_lvm2_lexer.mll +++ b/lib/diskimage_lvm2_lexer.mll @@ -26,8 +26,8 @@ open Printf open Lexing - open Virt_df - open Virt_df_lvm2_parser + open Diskimage_lvm2_parser + open Diskimage_utils (* Temporary buffer used for parsing strings, etc. *) let tmp = Buffer.create 80 diff --git a/virt-df/virt_df_lvm2_metadata.ml b/lib/diskimage_lvm2_metadata.ml similarity index 100% rename from virt-df/virt_df_lvm2_metadata.ml rename to lib/diskimage_lvm2_metadata.ml diff --git a/virt-df/virt_df_lvm2_metadata.mli b/lib/diskimage_lvm2_metadata.mli similarity index 100% rename from virt-df/virt_df_lvm2_metadata.mli rename to lib/diskimage_lvm2_metadata.mli diff --git a/virt-df/virt_df_lvm2_parser.mly b/lib/diskimage_lvm2_parser.mly similarity index 95% rename from virt-df/virt_df_lvm2_parser.mly rename to lib/diskimage_lvm2_parser.mly index c4ee574..f6d942f 100644 --- a/virt-df/virt_df_lvm2_parser.mly +++ b/lib/diskimage_lvm2_parser.mly @@ -23,7 +23,7 @@ */ %{ - open Virt_df_lvm2_metadata + open Diskimage_lvm2_metadata %} %token LBRACE RBRACE /* { } */ @@ -37,7 +37,7 @@ %token EOF /* end of file */ %start input -%type input +%type input %% diff --git a/virt-df/virt_df_mbr.ml b/lib/diskimage_mbr.ml similarity index 97% rename from virt-df/virt_df_mbr.ml rename to lib/diskimage_mbr.ml index f0e8c37..bd02f65 100644 --- a/virt-df/virt_df_mbr.ml +++ b/lib/diskimage_mbr.ml @@ -24,8 +24,7 @@ open Printf open Unix open ExtList -open Virt_df_gettext.Gettext -open Virt_df +open Diskimage_utils let sector_size = 512 let sector_size64 = 512L @@ -174,6 +173,3 @@ and uint64_of_int32 u32 = let i64 = Int64.of_int32 u32 in if u32 >= 0l then i64 else Int64.add i64 0x1_0000_0000_L - -(* Register with main code. *) -let () = partition_type_register "MBR" probe_mbr diff --git a/virt-df/virt_df_mbr.mli b/lib/diskimage_mbr.mli similarity index 88% rename from virt-df/virt_df_mbr.mli rename to lib/diskimage_mbr.mli index d32a0f8..4ba5e27 100644 --- a/virt-df/virt_df_mbr.mli +++ b/lib/diskimage_mbr.mli @@ -17,6 +17,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -(* This file is empty to stop this plug-in from exporting any - symbols to other modules by accident. -*) +(**/**) + +val probe_mbr : Diskimage_utils.device -> Diskimage_utils.partitions diff --git a/lib/diskimage_utils.ml b/lib/diskimage_utils.ml new file mode 100644 index 0000000..9290af3 --- /dev/null +++ b/lib/diskimage_utils.ml @@ -0,0 +1,204 @@ +(* Diskimage library for reading disk images. + (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 Unix + +let debug = ref false + +let ( +* ) = Int32.add +let ( -* ) = Int32.sub +let ( ** ) = Int32.mul +let ( /* ) = Int32.div + +let ( +^ ) = Int64.add +let ( -^ ) = Int64.sub +let ( *^ ) = Int64.mul +let ( /^ ) = Int64.div + +class virtual device = +object (self) + method virtual read : int64 -> int -> string + method virtual size : int64 + method virtual name : string + + method close () = () + + (* 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 close () = close fd + method size = size + method name = filename +end + +(* A linear offset/size from an underlying device. *) +class offset_device name start size (dev : device) = +object + inherit device + method name = name + method size = size + (* method close () = dev#close () - NB: NO!! Device may be shared. *) + method read offset len = + if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then + invalid_arg ( + sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)" + name offset len size + ); + dev#read (start+^offset) len +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 + +type machine = { + m_name : string; (* Machine name. *) + m_disks : disk list; (* Machine disks. *) + m_lv_filesystems : + (lv * filesystem) list; (* Machine LV filesystems. *) +} +and disk = { + d_name : string; (* Device name (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. *) +} + +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]" + +(* Convert a UUID (containing '-' chars) to canonical form. *) +let canonical_uuid uuid = + let uuid' = String.make 32 ' ' in + let j = ref 0 in + for i = 0 to String.length uuid - 1 do + if !j >= 32 then invalid_arg "canonical_uuid"; + let c = uuid.[i] in + if c <> '-' then ( uuid'.[!j] <- c; incr j ) + done; + if !j <> 32 then invalid_arg "canonical_uuid"; + uuid' + +(* 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' + +let rec range a b = + if a < b then a :: range (a+1) b + else [] diff --git a/lib/diskimage_utils.mli b/lib/diskimage_utils.mli new file mode 100644 index 0000000..91f43e0 --- /dev/null +++ b/lib/diskimage_utils.mli @@ -0,0 +1,141 @@ +(* (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. + *) + +(**/**) + +val debug : bool ref + +(** {2 Device model} *) + +class virtual device : + object + method virtual name : string + method virtual size : int64 + method close : unit -> unit + method virtual read : int64 -> int -> string + method read_bitstring : int64 -> int -> Bitmatch.bitstring + end + +class block_device : string -> + object + method name : string + method size : int64 + method close : unit -> unit + method read : int64 -> int -> string + method read_bitstring : int64 -> int -> Bitmatch.bitstring + end + +class offset_device : string -> int64 -> int64 -> device -> + object + method name : string + method size : int64 + method close : unit -> unit + method read : int64 -> int -> string + method read_bitstring : int64 -> int -> Bitmatch.bitstring + end + +val null_device : device + +type machine = { + m_name : string; + m_disks : disk list; + m_lv_filesystems : + (lv * filesystem) list; +} + +and disk = { + d_name : string; + d_dev : device; + d_content : disk_content; +} + +and disk_content = + [ `Filesystem of filesystem + | `Partitions of partitions + | `PhysicalVolume of pv + | `Unknown + ] + +and partitions = { + parts_name : string; + parts : partition list; +} +and partition = { + part_status : partition_status; + part_type : int; + part_dev : device; + part_content : partition_content; +} + +and partition_status = Bootable | Nonbootable | Malformed | NullEntry +and partition_content = + [ `Filesystem of filesystem + | `PhysicalVolume of pv + | `Unknown + ] + +and filesystem = { + fs_name : string; + fs_block_size : int64; + fs_blocks_total : int64; + fs_is_swap : bool; + fs_blocks_reserved : int64; + fs_blocks_avail : int64; + fs_blocks_used : int64; + fs_inodes_total : int64; + fs_inodes_reserved : int64; + fs_inodes_avail : int64; + fs_inodes_used : int64; +} + +and pv = { + lvm_plugin_id : lvm_plugin_id; + pv_uuid : string; +} +and lv = { + lv_dev : device; +} + +and lvm_plugin_id = string + +val string_of_partition : partition -> string +val string_of_filesystem : filesystem -> string + +(** {2 Internal functions used by the plug-ins} *) + +val canonical_uuid : string -> string + (** Convert a UUID which may contain '-' characters to canonical form. *) + +val group_by : ?cmp:('a -> 'a -> int) -> ('a * 'b) list -> ('a * 'b list) list +(** Group a sorted list of pairs by the first element of the pair. *) + +val range : int -> int -> int list +(** [range a b] returns the list of integers [a <= i < b]. + If [a >= b] then the empty list is returned. +*) + +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. *) diff --git a/virt-df/.depend b/virt-df/.depend index ae927d2..793019d 100644 --- a/virt-df/.depend +++ b/virt-df/.depend @@ -1,27 +1,6 @@ -virt_df_lvm2_parser.cmi: virt_df_lvm2_metadata.cmi virt_df_csv.cmo: virt_df.cmi virt_df_csv.cmi virt_df_csv.cmx: virt_df.cmx virt_df_csv.cmi -virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmi -virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmi -virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi -virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi -virt_df_lvm2_metadata.cmo: virt_df_lvm2_metadata.cmi -virt_df_lvm2_metadata.cmx: virt_df_lvm2_metadata.cmi -virt_df_lvm2.cmo: virt_df_lvm2_metadata.cmi virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_lvm2.cmi -virt_df_lvm2.cmx: virt_df_lvm2_metadata.cmx virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_lvm2.cmi -virt_df_lvm2_parser.cmo: virt_df_lvm2_metadata.cmi virt_df_lvm2_parser.cmi -virt_df_lvm2_parser.cmx: virt_df_lvm2_metadata.cmx virt_df_lvm2_parser.cmi -virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi -virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx -virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_mbr.cmi -virt_df_mbr.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_mbr.cmi +virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi ../lib/diskimage.cmi +virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx ../lib/diskimage.cmx virt_df.cmo: virt_df_gettext.cmo virt_df.cmi virt_df.cmx: virt_df_gettext.cmx virt_df.cmi diff --git a/virt-df/Makefile.in b/virt-df/Makefile.in index 0bc9139..a2da6ce 100644 --- a/virt-df/Makefile.in +++ b/virt-df/Makefile.in @@ -27,8 +27,8 @@ bindir = @bindir@ pkg_gettext = @pkg_gettext@ -#OCAMLCPACKAGES := -package unix,extlib,xml-light,bitmatch -OCAMLCPACKAGES := -package unix,extlib,xml-light,libvirt -I +bitmatch +#OCAMLCPACKAGES := -package unix,extlib,xml-light,libvirt,bitmatch -I ../lib +OCAMLCPACKAGES := -package unix,extlib,xml-light,libvirt -I +bitmatch -I ../lib ifneq ($(pkg_gettext),no) OCAMLCPACKAGES += -package gettext-stub @@ -40,15 +40,7 @@ endif # Library objects. OBJS := virt_df_gettext.cmo virt_df.cmo -# Plugin objects. -OBJS += virt_df_ext2.cmo \ - virt_df_linux_swap.cmo \ - virt_df_lvm2_metadata.cmo \ - virt_df_lvm2_parser.cmo \ - virt_df_lvm2_lexer.cmo \ - virt_df_lvm2.cmo \ - virt_df_mbr.cmo - +# Plug-in objects. ifneq ($(pkg_csv),no) OCAMLCPACKAGES += -package csv OBJS += virt_df_csv.cmo @@ -61,18 +53,14 @@ XOBJS := $(OBJS:.cmo=.cmx) #---------------------------------------------------------------------- -SYNTAX := -pp "camlp4o -I`ocamlc -where`/bitmatch pa_bitmatch.cmo" - -OCAMLCFLAGS := -g -w s $(SYNTAX) -#OCAMLCLIBS := -linkpkg -OCAMLCLIBS := -linkpkg bitmatch.cma +OCAMLCFLAGS := -g -w s +#OCAMLCLIBS := -linkpkg diskimage.cma +OCAMLCLIBS := -linkpkg bitmatch.cma diskimage.cma OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) -OCAMLOPTFLAGS := -w s $(SYNTAX) -#OCAMLOPTLIBS := $(OCAMLCLIBS) -OCAMLOPTLIBS := -linkpkg bitmatch.cmxa - -OCAMLDEPFLAGS := $(SYNTAX) +OCAMLOPTFLAGS := -w s +#OCAMLOPTLIBS := -linkpkg diskimage.cmxa +OCAMLOPTLIBS := -linkpkg bitmatch.cmxa diskimage.cmxa BYTE_TARGETS := virt-df OPT_TARGETS := virt-df.opt @@ -94,12 +82,6 @@ virt-df.opt: $(XOBJS) $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ -o $@ $^ -# 'make depend' doesn't catch these dependencies because the .mli file -# is auto-generated. -virt_df_lvm2_parser.cmi: virt_df_lvm2_parser.mli -virt_df_lvm2_parser.cmo: virt_df_lvm2_parser.mli -virt_df_lvm2_parser.cmx: virt_df_lvm2_parser.mli - # Manual page. ifeq ($(HAVE_PERLDOC),perldoc) virt-df.1: virt-df.pod diff --git a/virt-df/README b/virt-df/README index 65acef9..9c55a75 100644 --- a/virt-df/README +++ b/virt-df/README @@ -8,61 +8,4 @@ directory). Developer documentation ---------------------------------------------------------------------- -This program has suddenly become rather large and confusing. -Hopefully this documentation should go some way towards explaining -what is going on inside the source. - -The main program consists of two modules: - - - virt_df.ml / virt_df.mli (module name: Virt_df) - - This has evolved into a library of miscellaneous functions - and values which are included throughout the rest of the - program. If you see an unexplained function then it's - likely that it is defined in here. - - Start by reading virt_df.mli which contains the full types - and plenty of documentation. - - - virt_df_main.ml - - This is the program. It reads the command line arguments, - loads the domain descriptions, calls out to the plug-ins - to probe for disks / partitions / filesystems / etc., and - finally prints the results. - - The file consists of basically one large program that - does all of the above in sequence. - -Everything else in this directory is a plug-in specialized for probing -a particular filesystem, partition scheme or type of LVM. The -plug-ins at time of writing are: - - - virt_df_ext2.ml / virt_df_ext2.mli - - EXT2/3/4 plug-in. - - - virt_df_linux_swap.ml / virt_df_linux_swap.mli - - Linux swap (new style) plug-in. - - - virt_df_mbr.ml / virt_df_mbr.mli - - Master Boot Record (MS-DOS) disk partitioning plug-in. - - - virt_df_lvm2* - - LVM2 parsing, which is by far the most complex plug-in. - It consists of: - - - virt_df_lvm2.ml - - virt_df_lvm2.mli - LVM2 probing, PV detection. - - - virt_df_lvm2_parser.mly - - virt_df_lvm2_lexer.mll - Scanner/parser for parsing LVM2 metadata definitions. - - - virt_df_lvm2_metadata.ml - - virt_df_lvm2_metadata.mli - AST for LVM2 metadata definitions. +Please see ../lib/README. \ No newline at end of file diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index 2310b1c..b802077 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -19,20 +19,9 @@ open Printf open ExtList -open Unix open Virt_df_gettext.Gettext -let ( +* ) = Int32.add -let ( -* ) = Int32.sub -let ( ** ) = Int32.mul -let ( /* ) = Int32.div - -let ( +^ ) = Int64.add -let ( -^ ) = Int64.sub -let ( *^ ) = Int64.mul -let ( /^ ) = Int64.div - (* Command line arguments. *) let debug = ref false let uri = ref None @@ -44,255 +33,3 @@ let csv_mode = ref false (* Support for CSV (overridden by virt_df_csv.ml, if present). *) let csv_write = ref None - -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 linear offset/size from an underlying device. *) -class offset_device name start size (dev : device) = -object - inherit device - method name = name - method size = size - method read offset len = - if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then - invalid_arg ( - sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)" - name offset len size - ); - dev#read (start+^offset) len -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 - -type domain = { - dom_name : string; (* Domain name. *) - dom_id : int option; (* Domain ID (if running). *) - dom_disks : disk list; (* Domain disks. *) - dom_lv_filesystems : - (lv * filesystem) list; (* Domain LV filesystems. *) -} -and disk = { - (* From the XML ... *) - d_type : string option; (* The *) - d_device : string; (* The (eg "disk") *) - d_source : string; (* The *) - d_target : string; (* The (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. *) -} - -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]" - -(* Convert a UUID (containing '-' chars) to canonical form. *) -let canonical_uuid uuid = - let uuid' = String.make 32 ' ' in - let j = ref 0 in - for i = 0 to String.length uuid - 1 do - if !j >= 32 then - invalid_arg (sprintf (f_ "canonical_uuid: UUID is too long: %s") uuid); - let c = uuid.[i] in - if c <> '-' then ( uuid'.[!j] <- c; incr j ) - done; - if !j <> 32 then - invalid_arg (sprintf (f_ "canonical_uuid: invalid UUID: %s") uuid); - uuid' - -(* 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' - -let rec range a b = - if a < b then a :: range (a+1) b - else [] diff --git a/virt-df/virt_df.mli b/virt-df/virt_df.mli index 2815d9b..d13c5d3 100644 --- a/virt-df/virt_df.mli +++ b/virt-df/virt_df.mli @@ -21,16 +21,6 @@ used throughout the plug-ins and main code. *) -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 debug : bool ref (** If true, emit debug info to stderr*) val uri : string option ref (** Hypervisor/libvirt URI. *) val inodes : bool ref (** Display inodes. *) @@ -44,200 +34,3 @@ val csv_write : (out_channel -> string list -> unit) option ref (** If virt_df_csv.ml is compiled in then this hook is overridden with a function to write a single line to a CSV file. *) - -(** - {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. LVM2) 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. *) - -class offset_device : string -> int64 -> int64 -> device -> - 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 maps a linear part of an underlying device. - - [new offset_device name start size dev] creates a new - device which maps bytes from [start] to [start+size-1] - of the underlying device [dev] (ie. in this device they - appear as bytes [0] to [size-1]). - - Useful for things like partitions. - *) - -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. *) - dom_lv_filesystems : - (lv * filesystem) list; (** Domain LV filesystems. *) -} -and disk = { - d_type : string option; (** The *) - d_device : string; (** The (eg "disk") *) - d_source : string; (** The *) - d_target : string; (** The (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 pv (** 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 pv (** 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. *) -} -and pv = { - lvm_plugin_id : lvm_plugin_id; (** The LVM plug-in which detected - this. *) - pv_uuid : string; (** UUID. *) -} -and lv = { - lv_dev : device; (** Logical volume device. *) -} - -and lvm_plugin_id - -val string_of_partition : partition -> string -val string_of_filesystem : filesystem -> string -(** Convert a partition or filesystem struct to a string (for debugging). *) - -val canonical_uuid : string -> string -(** Convert a UUID which may contain '-' characters to canonical form. *) - -(** {2 Plug-in registration functions} *) - -val partition_type_register : string -> (device -> partitions) -> unit -(** Register a partition probing plug-in. *) - -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 plug-in. *) - -val probe_for_filesystem : device -> filesystem option -(** Do a filesystem probe on a device. Returns [Some filesystem] or [None]. *) - -val lvm_type_register : - string -> (lvm_plugin_id -> device -> pv) -> (device list -> lv list) -> unit -(** [lvm_type_register lvm_name probe_fn list_lvs_fn] - registers a new LVM type. [probe_fn] is a function which - should probe a device to find out if it contains a PV. - [list_lvs_fn] is a function which should take a list of - devices (PVs) and construct a list of LV devices. -*) - -val probe_for_pv : device -> pv option -(** Do a PV probe on a device. Returns [Some pv] or [None]. *) - -val list_lvs : lvm_plugin_id -> device list -> lv list -(** Construct LV devices from a list of PVs. *) - -(** {2 Utility functions} *) - -val group_by : ?cmp:('a -> 'a -> int) -> ('a * 'b) list -> ('a * 'b list) list -(** Group a sorted list of pairs by the first element of the pair. *) - -val range : int -> int -> int list -(** [range a b] returns the list of integers [a <= i < b]. - If [a >= b] then the empty list is returned. -*) diff --git a/virt-df/virt_df_csv.ml b/virt-df/virt_df_csv.ml index b2bf9f6..6cd2203 100644 --- a/virt-df/virt_df_csv.ml +++ b/virt-df/virt_df_csv.ml @@ -23,7 +23,7 @@ open Printf -open Virt_df +open Virt_df ;; csv_write := Some ( fun chan row -> diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index 2a97d5e..cd51c88 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -26,6 +26,16 @@ module D = Libvirt.Domain open Virt_df_gettext.Gettext open Virt_df +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 () = (* Command line argument parsing. *) let set_uri = function "" -> uri := None | u -> uri := Some u in @@ -53,7 +63,7 @@ let () = "uri " ^ s_ "Connect to URI (default: Xen)"; "--csv", Arg.Set csv_mode, " " ^ s_ "Write results in CSV format"; - "--debug", Arg.Set debug, + "--debug", Arg.Set Diskimage.debug, " " ^ s_ "Debug mode (default: false)"; "-h", Arg.Set human, " " ^ s_ "Print sizes in human-readable format"; @@ -93,7 +103,8 @@ OPTIONS" in csv_write stdout in - let doms : domain list = + (* name target dev_path *) + let doms : (string * (string * string) list) list = if !test_files = [] then ( let xmls = (* Connect to the hypervisor. *) @@ -146,9 +157,9 @@ OPTIONS" in | Xml.Element ("domain", attrs, children) -> children, attrs | _ -> failwith (s_ "get_xml_desc didn't return ") in - let domid = + (*let domid = try Some (int_of_string (List.assoc "id" domain_attrs)) - with Not_found -> None in + with Not_found -> None in*) let rec loop = function | [] -> @@ -197,9 +208,9 @@ OPTIONS" in List.filter_map ( function | Xml.Element ("disk", attrs, children) -> - let typ = + (*let typ = try Some (List.assoc "type" attrs) - with Not_found -> None in + with Not_found -> None in*) let device = try Some (List.assoc "device" attrs) with Not_found -> None in @@ -213,33 +224,15 @@ OPTIONS" in * 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.Unix_error (err, func, param) -> - eprintf "%s:%s: %s" func param - (Unix.error_message err); - None - ) + | _, _, Some "cdrom" -> None (* ignore CD-ROMs *) + | Some source, Some target, _ -> Some (target, source) | _ -> None (* ignore anything else *) ) | _ -> None ) devices in - { dom_name = name; dom_id = domid; - dom_disks = disks; dom_lv_filesystems = [] } + name, disks ) xmls ) else ( (* In test mode (-t option) the user can pass one or more @@ -249,150 +242,21 @@ OPTIONS" in *) 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 = [] - } + filename, ["hda", filename] ) !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 + (* Convert these to Diskimage library 'machine's. *) + let machines = List.filter_map ( + fun (name, disks) -> + try Some (Diskimage.open_machine name disks) + with Unix.Unix_error (err, func, param) -> + eprintf "%s:%s: %s" func param (Unix.error_message err); + None ) 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 + (* Scan them. *) + let machines = List.map Diskimage.scan_machine machines in (*----------------------------------------------------------------------*) (* Now print the results. *) @@ -420,87 +284,106 @@ OPTIONS" in in (* HOF to iterate over filesystems. *) - let iter_over_filesystems doms - (f : domain -> ?disk:disk -> ?partno:int -> device -> filesystem -> + let iter_over_filesystems machines + (f : Diskimage.machine -> ?disk:Diskimage.disk -> ?partno:int -> + Diskimage.device -> Diskimage.filesystem -> unit) = List.iter ( - fun ({ dom_disks = disks; dom_lv_filesystems = filesystems } as dom) -> + fun ({ Diskimage.m_disks = disks; + m_lv_filesystems = filesystems } as dom) -> (* Ordinary filesystems found on disks & partitions. *) List.iter ( function - | ({ d_content = `Filesystem fs; d_dev = dev } as disk) -> + | ({ Diskimage.d_content = `Filesystem fs; d_dev = dev } as disk) -> f dom ~disk dev fs - | ({ d_content = `Partitions partitions } as disk) -> + | ({ Diskimage.d_content = `Partitions partitions } as disk) -> List.iteri ( fun i -> function - | { part_content = `Filesystem fs; part_dev = dev } -> + | { Diskimage.part_content = `Filesystem fs; + part_dev = dev } -> f dom ~disk ~partno:(i+1) dev fs | _ -> () - ) partitions.parts + ) partitions.Diskimage.parts | _ -> () ) disks; (* LV filesystems. *) - List.iter (fun ({lv_dev = dev}, fs) -> f dom dev fs) filesystems - ) doms + List.iter ( + fun ({Diskimage.lv_dev = dev}, fs) -> f dom dev fs + ) filesystems + ) machines in (* Printable name is like "domain:hda" or "domain:hda1". *) - let printable_name dom ?disk ?partno dev = - let dom_name = dom.dom_name in + let printable_name machine ?disk ?partno dev = + let m_name = machine.Diskimage.m_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 + | Some disk -> disk.Diskimage.d_name in match partno with | None -> - dom_name ^ ":" ^ disk_name + m_name ^ ":" ^ disk_name | Some partno -> - dom_name ^ ":" ^ disk_name ^ string_of_int partno + m_name ^ ":" ^ disk_name ^ string_of_int partno in (* Print stats for each recognized filesystem. *) - let print_stats dom ?disk ?partno dev fs = - let name = printable_name dom ?disk ?partno dev in + let print_stats machine ?disk ?partno dev fs = + let name = printable_name machine ?disk ?partno dev in printf "%-32s " name; - if fs.fs_is_swap then ( + let { + Diskimage.fs_name = fs_name; + fs_block_size = fs_block_size; + fs_blocks_total = fs_blocks_total; + fs_is_swap = fs_is_swap; + fs_blocks_reserved = fs_blocks_reserved; + fs_blocks_avail = fs_blocks_avail; + fs_blocks_used = fs_blocks_used; + fs_inodes_total = fs_inodes_total; + fs_inodes_reserved = fs_inodes_reserved; + fs_inodes_avail = fs_inodes_avail; + fs_inodes_used = fs_inodes_used + } = fs in + + if 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 + (fs_block_size *^ fs_blocks_total /^ 1024L) fs_name else printf "%10s %s\n" - (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name + (printable_size (fs_block_size *^ fs_blocks_total)) 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_total = fs_blocks_total -^ fs_blocks_reserved in + let blocks_avail = fs_blocks_avail -^ 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 + (blocks_total *^ fs_block_size /^ 1024L) + (fs_blocks_used *^ fs_block_size /^ 1024L) + (blocks_avail *^ fs_block_size /^ 1024L) + 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 + (printable_size (blocks_total *^ fs_block_size)) + (printable_size (fs_blocks_used *^ fs_block_size)) + (printable_size (blocks_avail *^ fs_block_size)) + 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 + fs_inodes_total fs_inodes_used fs_inodes_avail + fs_name ) ) in @@ -509,35 +392,49 @@ OPTIONS" in * We ignore the human-readable option because we assume that * the data will be post-processed by something. *) - let print_stats_csv dom ?disk ?partno dev fs = - let name = printable_name dom ?disk ?partno dev in + let print_stats_csv machine ?disk ?partno dev fs = + let name = printable_name machine ?disk ?partno dev in + + let { + Diskimage.fs_name = fs_name; + fs_block_size = fs_block_size; + fs_blocks_total = fs_blocks_total; + fs_is_swap = fs_is_swap; + fs_blocks_reserved = fs_blocks_reserved; + fs_blocks_avail = fs_blocks_avail; + fs_blocks_used = fs_blocks_used; + fs_inodes_total = fs_inodes_total; + fs_inodes_reserved = fs_inodes_reserved; + fs_inodes_avail = fs_inodes_avail; + fs_inodes_used = fs_inodes_used + } = fs in let row = - if fs.fs_is_swap then + if fs_is_swap then (* Swap partition. *) - [ Int64.to_string (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L); + [ Int64.to_string (fs_block_size *^ fs_blocks_total /^ 1024L); ""; "" ] 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_total = fs_blocks_total -^ fs_blocks_reserved in + let blocks_avail = fs_blocks_avail -^ fs_blocks_reserved in let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in - [ Int64.to_string (blocks_total *^ fs.fs_block_size /^ 1024L); - Int64.to_string (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L); - Int64.to_string (blocks_avail *^ fs.fs_block_size /^ 1024L) ] + [ Int64.to_string (blocks_total *^ fs_block_size /^ 1024L); + Int64.to_string (fs_blocks_used *^ fs_block_size /^ 1024L); + Int64.to_string (blocks_avail *^ fs_block_size /^ 1024L) ] ) else ( (* Inodes display. *) - [ Int64.to_string fs.fs_inodes_total; - Int64.to_string fs.fs_inodes_used; - Int64.to_string fs.fs_inodes_avail ] + [ Int64.to_string fs_inodes_total; + Int64.to_string fs_inodes_used; + Int64.to_string fs_inodes_avail ] ) ) in - let row = name :: row @ [fs.fs_name] in + let row = name :: row @ [fs_name] in csv_write row in - iter_over_filesystems doms + iter_over_filesystems machines (if not !csv_mode then print_stats else print_stats_csv) -- 1.8.3.1