diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | Makefile.in | 6 | ||||
| -rw-r--r-- | configure.ac | 2 | ||||
| -rw-r--r-- | virt-df/Makefile.in | 12 | ||||
| -rw-r--r-- | virt-df/README | 35 | ||||
| -rw-r--r-- | virt-df/virt_df.ml | 553 | ||||
| -rw-r--r-- | virt-df/virt_df_ext2.ml | 84 | ||||
| -rw-r--r-- | virt-df/virt_df_linux_swap.ml | 24 | ||||
| -rw-r--r-- | virt-df/virt_df_lvm2.ml | 22 | ||||
| -rw-r--r-- | virt-df/virt_df_main.ml | 5 |
10 files changed, 607 insertions, 144 deletions
@@ -1,3 +1,11 @@ +2007-09-27 Richard Jones <rjones@redhat.com> + + * configure.ac: Changed version to 0.3.2.9. + * Makefile.in: Re-enable virt-df. + * virt-df/virt_df*.ml: Mostly finished off the core of virt-df. + Ext2/3 support. No LVM as yet. + * virt-df/README: Added README file. + 2007-09-24 Richard Jones <rjones@redhat.com> * configure.ac: Version 0.3.2.8 for release. diff --git a/Makefile.in b/Makefile.in index 789eaae..489a5e9 100644 --- a/Makefile.in +++ b/Makefile.in @@ -21,9 +21,9 @@ ifeq ($(pkg_curses),yes) SUBDIRS += virt-top endif -#ifeq ($(pkg_xml_light),yes) -#SUBDIRS += virt-df -#endif +ifeq ($(pkg_xml_light),yes) +SUBDIRS += virt-df +endif all opt depend install: for d in $(SUBDIRS); do \ diff --git a/configure.ac b/configure.ac index 87d6628..cdeead0 100644 --- a/configure.ac +++ b/configure.ac @@ -1,6 +1,6 @@ dnl Process this file with autoconf to produce a configure script. -AC_INIT(ocaml-libvirt,0.3.2.8) +AC_INIT(ocaml-libvirt,0.3.2.9) dnl Check for basic C environment. AC_PROG_CC diff --git a/virt-df/Makefile.in b/virt-df/Makefile.in index ed820e6..ef456df 100644 --- a/virt-df/Makefile.in +++ b/virt-df/Makefile.in @@ -14,7 +14,11 @@ pkg_xml_light = @pkg_xml_light@ OCAMLCPACKAGES := -package unix,extlib,xml-light -OBJS := virt_df.cmo +OBJS := virt_df.cmo \ + virt_df_ext2.cmo \ + virt_df_linux_swap.cmo \ + virt_df_lvm2.cmo \ + virt_df_main.cmo XOBJS := $(OBJS:.cmo=.cmx) OCAMLCPACKAGES += -I ../libvirt @@ -32,7 +36,7 @@ BYTE_TARGETS := virt-df OPT_TARGETS := virt-df.opt #ifeq ($(HAVE_PERLDOC),perldoc) -#BYTE_TARGETS += virt-top.1 virt-top.txt +#BYTE_TARGETS += virt-df.1 virt-df.txt #endif all: $(BYTE_TARGETS) @@ -50,11 +54,11 @@ virt-df.opt: $(XOBJS) # Manual page. #ifeq ($(HAVE_PERLDOC),perldoc) -#virt-top.1: virt-top.pod +#virt-df.1: virt-df.pod # pod2man -c "Virtualization Support" --release "$(PACKAGE)-$(VERSION)" \ # $< > $@ # -#virt-top.txt: virt-top.pod +#virt-df.txt: virt-df.pod # pod2text $< > $@ #endif diff --git a/virt-df/README b/virt-df/README new file mode 100644 index 0000000..7b53f3e --- /dev/null +++ b/virt-df/README @@ -0,0 +1,35 @@ +$Id$ + +virt-df is a 'df' tool for printing out the used and available disk +space in all active and inactive domains. Without this tool you would +need to log in to each domain individually or set up monitoring. + +It is only a proof-of-concept. Please bare in mind the following +limitations when using this tool: + +(1) It does not work over remote connections. Part of the reason why +I wrote virt-df was to get an idea of how the remote storage API for +libvirt might look. + +(2) It only understands a limited set of partition types. Assuming +that the files and partitions that we get back from libvirt / Xen +correspond to block devices in the guests, we can go some way towards +manually parsing those partitions to find out what they contain. We +can read the MBR, LVM, superblocks and so on. However that's a lot of +parsing work, and currently there is no library which understands a +wide range of partition schemes and filesystem types (not even +libparted which doesn't support LVM yet). The Linux kernel does +support that, but there's not really any good way to access that work. + +The current implementation uses a hand-coded parser which understands +some simple formats (MBR, LVM2, ext2/3). In future we should use +something like libparted. + +(3) The statistics you get are delayed. The real state of, for +example, an ext2 filesystem is only stored in the memory of the +guest's kernel. The ext2 superblock contains some meta-information +about blocks used and free, but this superblock is not up to date. In +fact the guest kernel may not update it even on a 'sync', not until +the filesystem is unmounted. Some operations do appear to write the +superblock, for example fsync(2) [that is my reading of the ext2/3 +source code at least]. diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index d651fa3..4a5f0ed 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -5,19 +5,316 @@ open Printf open ExtList +open Unix + module C = Libvirt.Connect module D = Libvirt.Domain module N = Libvirt.Network +(* Int64 operators for convenience. + * For sanity we do all int operations as int64's. + *) +let (+^) = Int64.add +let (-^) = Int64.sub +let ( *^ ) = Int64.mul +let (/^) = Int64.div + let uri = ref None +let inodes = ref false +let human = ref false + +(* Maximum number of extended partitions possible. *) +let max_extended_partitions = 100 + +let sector_size = 512L + +(* Parse out the device XML to get the names of disks. *) +type domain = { + dom_name : string; (* Domain name. *) + dom_id : int option; (* Domain ID (if running). *) + dom_disks : disk list; (* Domain disks. *) +} +and disk = { + d_type : string option; (* The <disk type=...> *) + d_device : string option; (* The <disk device=...> *) + d_source : string option; (* The <source file=... or dev> *) + d_target : string option; (* The <target dev=...> *) +} + +type partition = { + part_status : partition_status; (* Bootable, etc. *) + part_type : int; (* Partition type. *) + part_lba_start : int64; (* LBA start sector. *) + part_len : int64; (* Length in sectors. *) +} +and partition_status = Bootable | Nonbootable | Malformed | NullEntry + +type filesystem_stats = { + fs_name : string; + fs_block_size : int64; (* Block size (bytes). *) + fs_blocks_total : int64; (* Total blocks. *) + 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 swap_stats = { + swap_name : string; + swap_block_size : int64; (* Block size (bytes). *) + swap_blocks_total : int64; (* Total blocks. *) +} +and fs_probe_t = (* Return type of the probe_partition.*) + | Filesystem of filesystem_stats + | Swap of swap_stats + | ProbeFailed of string (* Probe failed for some reason. *) + | ProbeIgnore (* This filesystem should be ignored. *) + +(* Register a filesystem type. *) +let filesystems = Hashtbl.create 13 +let fs_register part_types probe_fn = + List.iter + (fun part_type -> Hashtbl.replace filesystems part_type probe_fn) + part_types + +(* Probe the devices and display. + * - dom_name is the domain name + * - target will be something like "hda" + * - source will be the name of a file or disk partition on the local machine + *) +let rec probe_device dom_name target source = + let fd = openfile source [ O_RDONLY ] 0 in + let size = (LargeFile.fstat fd).LargeFile.st_size in + let size = size /^ sector_size in (* Size in sectors. *) + + print_device dom_name target source size; + + let partitions = probe_mbr fd in + + if partitions <> [] then ( + let stats = + List.mapi ( + fun i part -> + if part.part_status = Bootable || + part.part_status = Nonbootable then ( + let pnum = i+1 in + let target = target ^ string_of_int pnum in + Some (target, + probe_partition target (Some part.part_type) + fd part.part_lba_start part.part_len) + ) + else + None + ) partitions in + let stats = List.filter_map (fun x -> x) stats in + print_stats stats + ) else (* Not an MBR, assume it's a single partition. *) + print_stats [target, probe_partition target None fd 0L size]; + + close fd + +(* Probe the master boot record (if it is one) and read the partitions. + * Returns [] if this is not an MBR. + * http://en.wikipedia.org/wiki/Master_boot_record + *) +and probe_mbr fd = + lseek fd 510 SEEK_SET; + let str = String.create 2 in + if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then + [] (* Not MBR *) + else ( + (* Read the partition table. *) + lseek fd 446 SEEK_SET; + let str = String.create 64 in + if read fd str 0 64 <> 64 then + failwith "error reading partition table" + else ( + (* Extract partitions from the data. *) + let primaries = List.map (get_partition str) [ 0; 16; 32; 48 ] in + (* XXX validate partition extents compared to disk. *) + (* Read extended partition data. *) + let extendeds = List.map ( + function + | { part_type = 0x05 } as part -> + probe_extended_partition + max_extended_partitions fd part part.part_lba_start + | part -> [] + ) primaries in + let extendeds = List.concat extendeds in + primaries @ extendeds + ) + ) + +(* Probe an extended partition. *) +and probe_extended_partition max fd epart sect = + if max > 0 then ( + (* Offset of the first EBR. *) + let ebr_offs = sect *^ sector_size in + (* EBR Signature? *) + LargeFile.lseek fd (ebr_offs +^ 510L) SEEK_SET; + let str = String.create 2 in + if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then + [] (* Not EBR *) + else ( + (* Read the extended partition table entries (just 2 of them). *) + LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET; + let str = String.create 32 in + if read fd str 0 32 <> 32 then + failwith "error reading extended partition" + else ( + (* Extract partitions from the data. *) + let part1, part2 = + match List.map (get_partition str) [ 0; 16 ] with + | [p1;p2] -> p1,p2 + | _ -> failwith "probe_extended_partition: internal error" in + (* First partition entry has offset to the start of this partition. *) + let part1 = { part1 with + part_lba_start = sect +^ part1.part_lba_start } in + (* Second partition entry is zeroes if end of list, otherwise points + * to the next partition. + *) + if part2.part_status = NullEntry then + [part1] + else + part1 :: probe_extended_partition + (max-1) fd epart (sect +^ part2.part_lba_start) + ) + ) + ) + else [] + +(* Get the partition data from str.[offs] - str.[offs+15] *) +and get_partition str offs = + let part_type = Char.code str.[offs+4] in + let part_lba_start = read_int32_le str (offs+8) in + let part_len = read_int32_le str (offs+12) in + + let part_status = + if part_type = 0 && part_lba_start = 0L && part_len = 0L then + NullEntry + else ( + let part_status = Char.code str.[offs] in + match part_status with + | 0x80 -> Bootable | 0 -> Nonbootable | _ -> Malformed + ) in + + { part_status = part_status; + part_type = part_type; + part_lba_start = part_lba_start; + part_len = part_len } + +(* Probe a single partition, which we assume contains either a + * filesystem or is a PV. + * - target will be something like "hda" or "hda1" + * - part_type will be the partition type if known, or None + * - fd is a file descriptor opened on the device + * - start & size are where we think the start and size of the + * partition is within the file descriptor (in SECTORS) + *) +and probe_partition target part_type fd start size = + match part_type with + | None -> + ProbeFailed "detection of unpartitioned devices not yet supported" + | Some 0x05 -> + ProbeIgnore (* Extended partition - ignore it. *) + | Some part_type -> + try + let probe_fn = Hashtbl.find filesystems part_type in + probe_fn target part_type fd start size + with + Not_found -> + ProbeFailed + (sprintf "unsupported partition type %02x" part_type) + +and print_stats statss = + List.iter ( + function + (* Swap partition. *) + | (target, Swap { swap_name = swap_name; + swap_block_size = block_size; + swap_blocks_total = blocks_total }) -> + if not !human then + printf "\t%s %Ld %s\n" + target (block_size *^ blocks_total /^ 1024L) swap_name + else + printf "\t%s %s %s\n" + target (printable_size (block_size *^ blocks_total)) swap_name + + (* Ordinary filesystem. *) + | (target, Filesystem stats) -> + printf "\t%s " target; + + if not !inodes then ( (* Block display. *) + (* 'df' doesn't count the restricted blocks. *) + let blocks_total = + stats.fs_blocks_total -^ stats.fs_blocks_reserved in + let blocks_avail = + stats.fs_blocks_avail -^ stats.fs_blocks_reserved in + let blocks_avail = + if blocks_avail < 0L then 0L else blocks_avail in + + if not !human then ( (* Display 1K blocks. *) + printf "%Ld %Ld %Ld %s\n" + (blocks_total *^ stats.fs_block_size /^ 1024L) + (stats.fs_blocks_used *^ stats.fs_block_size /^ 1024L) + (blocks_avail *^ stats.fs_block_size /^ 1024L) + stats.fs_name + ) else ( (* Human-readable blocks. *) + printf "%s %s %s %s\n" + (printable_size (blocks_total *^ stats.fs_block_size)) + (printable_size (stats.fs_blocks_used *^ stats.fs_block_size)) + (printable_size (blocks_avail *^ stats.fs_block_size)) + stats.fs_name + ) + ) else ( (* Inodes display. *) + printf "%Ld %Ld %Ld %s\n" + stats.fs_inodes_total stats.fs_inodes_used stats.fs_inodes_avail + stats.fs_name + ) + + (* Unsupported filesystem or other failure. *) + | (target, ProbeFailed reason) -> + printf "\t%s %s\n" target reason + + | (_, ProbeIgnore) -> () + ) statss + +(* Target is something like "hda" and size is the size in sectors. *) +and print_device dom_name target source size = + printf "%s /dev/%s (%s) %s\n" + dom_name target (printable_size (size *^ sector_size)) source + +and printable_size bytes = + if bytes < 1024L *^ 1024L then + sprintf "%Ld bytes" bytes + else if bytes < 1024L *^ 1024L *^ 1024L then + sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.) + else + sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.) -let () = +and read_int32_le str offs = + Int64.of_int (Char.code str.[offs]) +^ + 256L *^ Int64.of_int (Char.code str.[offs+1]) +^ + 65536L *^ Int64.of_int (Char.code str.[offs+2]) +^ + 16777216L *^ Int64.of_int (Char.code str.[offs+3]) + +and read_int16_le str offs = + Int64.of_int (Char.code str.[offs]) +^ + 256L *^ Int64.of_int (Char.code str.[offs+1]) + +let main () = (* Command line argument parsing. *) let set_uri = function "" -> uri := None | u -> uri := Some u in let argspec = Arg.align [ "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)"; "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)"; + "-h", Arg.Set human, " Print sizes in human-readable format"; + "--human-readable", Arg.Set human, " Print sizes in human-readable format"; + "-i", Arg.Set inodes, " Show inodes instead of blocks"; + "--inodes", Arg.Set inodes, " Show inodes instead of blocks"; ] in let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in @@ -28,152 +325,136 @@ SUMMARY OPTIONS" in - Arg.parse argspec anon_fun usage_msg - -let xmls = - (* Connect to the hypervisor. *) - let conn = - let name = !uri in - try C.connect_readonly ?name () - with - Libvirt.Virterror err -> - prerr_endline (Libvirt.Virterror.to_string err); - (* If non-root and no explicit connection URI, print a warning. *) - if Unix.geteuid () <> 0 && name = None then ( - print_endline "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 - 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 + Arg.parse argspec anon_fun usage_msg; -(* Parse out the device XML to get the names of disks. *) -type domain = { - dom_name : string; (* Domain name. *) - dom_id : int option; (* Domain ID (if running). *) - dom_disks : disk list; (* Domain disks. *) -} -and disk = { - d_type : string option; (* The <disk type=...> *) - d_device : string option; (* The <disk device=...> *) - d_source : string option; (* The <source file=... or dev> *) - d_target : string option; (* The <target dev=...> *) -} + 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 "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 + let nr_inactive_doms = C.num_of_defined_domains conn in + let inactive_doms = + Array.to_list (C.list_defined_domains conn nr_inactive_doms) in + let inactive_doms = List.map (D.lookup_by_name conn) inactive_doms in + active_doms @ inactive_doms in + + (* Get their XML. *) + let xmls = List.map D.get_xml_desc doms in + + (* Parse the XML. *) + let xmls = List.map Xml.parse_string xmls in + + (* Return just the XML documents - everything else will be closed + * and freed including the connection to the hypervisor. + *) + xmls in + + let doms : domain list = + (* Grr.. Need to use a library which has XPATH support (or cduce). *) + List.map ( + fun xml -> + let nodes, domain_attrs = + match xml with + | Xml.Element ("domain", attrs, children) -> children, attrs + | _ -> failwith "get_xml_desc didn't return <domain/>" in + + let domid = + try Some (int_of_string (List.assoc "id" domain_attrs)) + with Not_found -> None in + + let rec loop = function + | [] -> + failwith "get_xml_desc returned no <name> node in XML" + | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name + | Xml.Element ("name", _, _) :: _ -> + failwith "get_xml_desc returned strange <name> node" + | _ :: rest -> loop rest + in + let name = loop nodes in -let doms : domain list = - (* Grr.. Need to use a library which has XPATH support (or cduce). *) - List.map ( - fun xml -> - let nodes, domain_attrs = - match xml with - | Xml.Element ("domain", attrs, children) -> children, attrs - | _ -> failwith "get_xml_desc didn't return <domain/>" in - - let domid = - try Some (int_of_string (List.assoc "id" domain_attrs)) - with Not_found -> None in - - let rec loop = function - | [] -> - failwith "get_xml_desc returned no <name> node in XML" - | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name - | Xml.Element ("name", _, _) :: _ -> - failwith "get_xml_desc returned strange <name> node" - | _ :: rest -> loop rest - in - let name = loop nodes in - - let devices = let devices = + let devices = + List.filter_map ( + function + | Xml.Element ("devices", _, devices) -> Some devices + | _ -> None + ) nodes in + List.concat devices in + + let rec target_dev_of = function + | [] -> None + | Xml.Element ("target", attrs, _) :: rest -> + (try Some (List.assoc "dev" attrs) + with Not_found -> target_dev_of rest) + | _ :: rest -> target_dev_of rest + in + + let rec source_file_of = function + | [] -> None + | Xml.Element ("source", attrs, _) :: rest -> + (try Some (List.assoc "file" attrs) + with Not_found -> source_file_of rest) + | _ :: rest -> source_file_of rest + in + + let rec source_dev_of = function + | [] -> None + | Xml.Element ("source", attrs, _) :: rest -> + (try Some (List.assoc "dev" attrs) + with Not_found -> source_dev_of rest) + | _ :: rest -> source_dev_of rest + in + + let disks = List.filter_map ( function - | Xml.Element ("devices", _, devices) -> Some devices + | Xml.Element ("disk", attrs, children) -> + let typ = + try Some (List.assoc "type" attrs) + with Not_found -> None in + let device = + try Some (List.assoc "device" attrs) + with Not_found -> None in + let source = + match source_file_of children with + | (Some _) as source -> source + | None -> source_dev_of children in + let target = target_dev_of children in + + Some { + d_type = typ; d_device = device; + d_source = source; d_target = target + } | _ -> None - ) nodes in - List.concat devices in - - let rec target_dev_of = function - | [] -> None - | Xml.Element ("target", attrs, _) :: rest -> - (try Some (List.assoc "dev" attrs) - with Not_found -> target_dev_of rest) - | _ :: rest -> target_dev_of rest - in - - let rec source_file_of = function - | [] -> None - | Xml.Element ("source", attrs, _) :: rest -> - (try Some (List.assoc "file" attrs) - with Not_found -> source_file_of rest) - | _ :: rest -> source_file_of rest - in - - let rec source_dev_of = function - | [] -> None - | Xml.Element ("source", attrs, _) :: rest -> - (try Some (List.assoc "dev" attrs) - with Not_found -> source_dev_of rest) - | _ :: rest -> source_dev_of rest - in - - let disks = - List.filter_map ( - function - | Xml.Element ("disk", attrs, children) -> - let typ = - try Some (List.assoc "type" attrs) - with Not_found -> None in - let device = - try Some (List.assoc "device" attrs) - with Not_found -> None in - let source = - match source_file_of children with - | (Some _) as source -> source - | None -> source_dev_of children in - let target = target_dev_of children in - - Some { - d_type = typ; d_device = device; - d_source = source; d_target = target - } - | _ -> None - ) devices in - - { dom_name = name; dom_id = domid; dom_disks = disks } - ) xmls - -(* Print the domains / devices. *) -let () = + ) devices in + + { dom_name = name; dom_id = domid; dom_disks = disks } + ) xmls in + + (* Probe the devices. *) List.iter ( fun { dom_name = dom_name; dom_disks = dom_disks } -> - printf "%s:\n" dom_name; List.iter ( function | { d_source = Some source; d_target = Some target } -> - printf "\t%s -> %s\n" source target - | { d_type = None; d_device = Some "cdrom"; - d_source = None; d_target = Some target } -> - printf "\t[CD] -> %s\n" target + probe_device dom_name target source + | { d_device = Some "cdrom" } -> + () (* Ignore physical CD-ROM devices. *) | _ -> - printf "\t(device omitted, missing <source> or <target> in XML\n"; + printf "(device omitted)\n"; ) dom_disks ) doms diff --git a/virt-df/virt_df_ext2.ml b/virt-df/virt_df_ext2.ml new file mode 100644 index 0000000..f58491a --- /dev/null +++ b/virt-df/virt_df_ext2.ml @@ -0,0 +1,84 @@ +(* 'df' command for virtual domains. + * $Id$ + * + * Support for EXT2/EXT3 filesystems. + *) + +open Unix +open Printf + +(* Int64 operators for convenience. *) +let (+^) = Int64.add +let (-^) = Int64.sub +let ( *^ ) = Int64.mul +let (/^) = Int64.div + +let sector_size = Virt_df.sector_size +let read_int32_le = Virt_df.read_int32_le + +let probe_ext2 target part_type fd start size = + LargeFile.lseek fd ((start+^2L) *^ sector_size) SEEK_SET; + let str = String.create 128 in + if read fd str 0 128 <> 128 then + failwith "error reading ext2/ext3 magic" + else ( + if str.[56] != '\x53' || str.[57] != '\xEF' then ( + Virt_df.ProbeFailed "partition marked EXT2/3 but no valid filesystem" + ) else ( + (* Refer to <linux/ext2_fs.h> *) + let s_inodes_count = read_int32_le str 0 in + let s_blocks_count = read_int32_le str 4 in + let s_r_blocks_count = read_int32_le str 8 in + let s_free_blocks_count = read_int32_le str 12 in + let s_free_inodes_count = read_int32_le str 16 in + let s_first_data_block = read_int32_le str 20 in + let s_log_block_size = read_int32_le str 24 in + (*let s_log_frag_size = read_int32_le str 28 in*) + let s_blocks_per_group = read_int32_le str 32 in + + (* Work out the block size in bytes. *) + let s_log_block_size = Int64.to_int s_log_block_size in + let block_size = 1024L in + let block_size = Int64.shift_left block_size s_log_block_size in + + (* Number of groups. *) + let s_groups_count = + (s_blocks_count -^ s_first_data_block -^ 1L) + /^ s_blocks_per_group +^ 1L in + +(* + (* Number of group descriptors per block. *) + let s_inodes_per_block = s_blocksize / + let s_desc_per_block = block_size / s_inodes_per_block in + let db_count = + (s_groups_count +^ s_desc_per_block -^ 1L) + /^ s_desc_per_block +*) + + (* Calculate the block overhead (used by superblocks, inodes, etc.) + * See fs/ext2/super.c. + *) + let overhead = s_first_data_block in + let overhead = (* XXX *) overhead in + + + Virt_df.Filesystem { + Virt_df.fs_name = "Linux ext2/3"; + fs_block_size = block_size; + fs_blocks_total = s_blocks_count -^ overhead; + fs_blocks_reserved = s_r_blocks_count; + fs_blocks_avail = s_free_blocks_count; + fs_blocks_used = s_blocks_count -^ overhead -^ s_free_blocks_count; + fs_inodes_total = s_inodes_count; + fs_inodes_reserved = 0L; (* XXX? *) + fs_inodes_avail = s_free_inodes_count; + fs_inodes_used = s_inodes_count (*-^ 0L*) -^ s_free_inodes_count; + } + ) + ) + +(* Register with main code. *) +let () = + Virt_df.fs_register + [ 0x83 ] (* Partition type. *) + probe_ext2 diff --git a/virt-df/virt_df_linux_swap.ml b/virt-df/virt_df_linux_swap.ml new file mode 100644 index 0000000..a1f759a --- /dev/null +++ b/virt-df/virt_df_linux_swap.ml @@ -0,0 +1,24 @@ +(* 'df' command for virtual domains. + * $Id$ + * + * Support for Linux swap partitions. + *) + +(* Int64 operators for convenience. *) +let (+^) = Int64.add +let (-^) = Int64.sub +let ( *^ ) = Int64.mul +let (/^) = Int64.div + +let probe_swap target part_type fd start size = + Virt_df.Swap { + Virt_df.swap_name = "Linux swap"; + swap_block_size = 4096L; (* XXX *) + swap_blocks_total = size *^ 512L /^ 4096L; + } + +(* Register with main code. *) +let () = + Virt_df.fs_register + [ 0x82 ] (* Partition type. *) + probe_swap diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml new file mode 100644 index 0000000..a1f77e3 --- /dev/null +++ b/virt-df/virt_df_lvm2.ml @@ -0,0 +1,22 @@ +(* 'df' command for virtual domains. + * $Id$ + * + * Support for LVM2 PVs. + *) + +open Printf + +(* Int64 operators for convenience. *) +let (+^) = Int64.add +let (-^) = Int64.sub +let ( *^ ) = Int64.mul +let (/^) = Int64.div + +let probe_lvm2 target part_type fd start size = + Virt_df.ProbeFailed "LVM2 not supported yet" + +(* Register with main code. *) +let () = + Virt_df.fs_register + [ 0x8e ] (* Partition type. *) + probe_lvm2 diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml new file mode 100644 index 0000000..2f9f1bf --- /dev/null +++ b/virt-df/virt_df_main.ml @@ -0,0 +1,5 @@ +(* 'df' command for virtual domains. + * $Id$ + *) + +let () = Virt_df.main () |