From: Richard W.M. Jones <"Richard W.M. Jones "> Date: Fri, 2 May 2008 16:24:33 +0000 (+0100) Subject: Restructure library plug-ins again. X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=71536ae75dceb08e0f3c3403033fb2eb25a08883;p=virt-df.git Restructure library plug-ins again. --- diff --git a/lib/.depend b/lib/.depend index 8fc3cf7..a121753 100644 --- a/lib/.depend +++ b/lib/.depend @@ -1,46 +1,41 @@ -diskimage_ext2.cmi: diskimage_utils.cmi -diskimage_linux_swap.cmi: diskimage_utils.cmi -diskimage_linux_swsuspend.cmi: diskimage_utils.cmi +diskimage_impl.cmi: int63.cmi /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_lvm2_metadata.cmi: int63.cmi -diskimage_lvm2.cmi: diskimage_utils.cmi diskimage_lvm2_parser.cmi: int63.cmi diskimage_lvm2_metadata.cmi -diskimage_mbr.cmi: diskimage_utils.cmi diskimage.cmi: int63.cmi /usr/lib64/ocaml/bitmatch/bitmatch.cmi -diskimage_utils.cmi: int63.cmi /usr/lib64/ocaml/bitmatch/bitmatch.cmi -diskimage_ext2.cmo: int63.cmi diskimage_utils.cmi \ +diskimage_ext2.cmo: int63.cmi diskimage_impl.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_ext2.cmi -diskimage_ext2.cmx: int63.cmx diskimage_utils.cmx \ +diskimage_ext2.cmx: int63.cmx diskimage_impl.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_ext2.cmi -diskimage_linux_swap.cmo: int63.cmi diskimage_utils.cmi \ +diskimage_impl.cmo: int63.cmi diskimage_impl.cmi +diskimage_impl.cmx: int63.cmx diskimage_impl.cmi +diskimage_linux_swap.cmo: int63.cmi diskimage_impl.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_linux_swap.cmi -diskimage_linux_swap.cmx: int63.cmx diskimage_utils.cmx \ +diskimage_linux_swap.cmx: int63.cmx diskimage_impl.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_linux_swap.cmi -diskimage_linux_swsuspend.cmo: int63.cmi diskimage_utils.cmi \ +diskimage_linux_swsuspend.cmo: int63.cmi diskimage_impl.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_linux_swsuspend.cmi -diskimage_linux_swsuspend.cmx: int63.cmx diskimage_utils.cmx \ +diskimage_linux_swsuspend.cmx: int63.cmx diskimage_impl.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_linux_swsuspend.cmi diskimage_lvm2_metadata.cmo: int63.cmi diskimage_lvm2_metadata.cmi diskimage_lvm2_metadata.cmx: int63.cmx diskimage_lvm2_metadata.cmi -diskimage_lvm2.cmo: int63.cmi diskimage_utils.cmi diskimage_lvm2_metadata.cmi \ +diskimage_lvm2.cmo: int63.cmi diskimage_lvm2_metadata.cmi diskimage_impl.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_lvm2.cmi -diskimage_lvm2.cmx: int63.cmx diskimage_utils.cmx diskimage_lvm2_metadata.cmx \ +diskimage_lvm2.cmx: int63.cmx diskimage_lvm2_metadata.cmx diskimage_impl.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_lvm2.cmi diskimage_lvm2_parser.cmo: int63.cmi diskimage_lvm2_metadata.cmi \ diskimage_lvm2_parser.cmi diskimage_lvm2_parser.cmx: int63.cmx diskimage_lvm2_metadata.cmx \ diskimage_lvm2_parser.cmi -diskimage_mbr.cmo: int63.cmi diskimage_utils.cmi \ +diskimage_mbr.cmo: int63.cmi diskimage_impl.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_mbr.cmi -diskimage_mbr.cmx: int63.cmx diskimage_utils.cmx \ +diskimage_mbr.cmx: int63.cmx diskimage_impl.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_mbr.cmi -diskimage.cmo: int63.cmi diskimage_utils.cmi diskimage_mbr.cmi \ - diskimage_lvm2.cmi diskimage_linux_swsuspend.cmi diskimage_linux_swap.cmi \ +diskimage.cmo: diskimage_mbr.cmi diskimage_lvm2.cmi \ + diskimage_linux_swsuspend.cmi diskimage_linux_swap.cmi diskimage_impl.cmi \ diskimage_ext2.cmi diskimage.cmi -diskimage.cmx: int63.cmx diskimage_utils.cmx diskimage_mbr.cmx \ - diskimage_lvm2.cmx diskimage_linux_swsuspend.cmx diskimage_linux_swap.cmx \ +diskimage.cmx: diskimage_mbr.cmx diskimage_lvm2.cmx \ + diskimage_linux_swsuspend.cmx diskimage_linux_swap.cmx diskimage_impl.cmx \ diskimage_ext2.cmx diskimage.cmi -diskimage_utils.cmo: int63.cmi diskimage_utils.cmi -diskimage_utils.cmx: int63.cmx diskimage_utils.cmi int63.cmo: int63.cmi int63.cmx: int63.cmi int63_on_32.cmo: int63_on_32.cmi diff --git a/lib/Makefile.in b/lib/Makefile.in index 1a5fc58..4aa0e48 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -35,7 +35,7 @@ OCAMLCPACKAGES := -package unix,extlib -I +bitmatch # Build up the list of object files. OBJS := int63.cmo \ - diskimage_utils.cmo + diskimage_impl.cmo # Plugin objects. OBJS += diskimage_ext2.cmo \ diff --git a/lib/diskimage.ml b/lib/diskimage.ml index 6c2ef01..c4ab516 100644 --- a/lib/diskimage.ml +++ b/lib/diskimage.ml @@ -17,710 +17,13 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -open Printf -open ExtList -open Unix +include Diskimage_impl -open Int63.Operators - -include Diskimage_utils - -(* Use as the natural block size for disk images, but really we should - * use the 'blockdev -getbsz' command to find the real block size. - *) -let disk_block_size = ~^512 - -(*----------------------------------------------------------------------*) -(* The plug-ins. *) -let partition_types = [ - Diskimage_mbr.plugin_id, - ("MBR", Diskimage_mbr.callbacks); -] - -let filesystem_types = [ - Diskimage_ext2.plugin_id, - ("Linux ext2/3", Diskimage_ext2.callbacks); - Diskimage_linux_swap.plugin_id, - ("Linux swap", Diskimage_linux_swap.callbacks); - Diskimage_linux_swsuspend.plugin_id, - ("Linux s/w suspend", Diskimage_linux_swsuspend.callbacks); -] - -let lvm_types = [ - Diskimage_lvm2.plugin_id, - ("Linux LVM2", Diskimage_lvm2.callbacks); -] - -let name_of_parts id = - let name, _ = List.assoc id partition_types in - name -let name_of_filesystem id = - let name, _ = List.assoc id filesystem_types in - name -let name_of_lvm id = - let name, _ = List.assoc id lvm_types in - name - -(* 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_plugin_id, (_, cb)) :: rest -> - try Some (cb.parts_cb_probe 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_plugin_id = name; parts = parts } -> - eprintf "found %d %s partitions on %s\n" - (List.length parts) name dev#name - ); - r - -let parts_offset_is_free ({ parts_plugin_id = parts_name } as parts) offset = - let _, cb = List.assoc parts_name partition_types in - cb.parts_cb_offset_is_free parts offset - -(* 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, (_, cb)) :: rest -> - try Some (cb.fs_cb_probe 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%!" fs.fs_plugin_id - ); - r - -let fs_offset_is_free ({ fs_plugin_id = fs_name } as fs) offset = - let _, cb = List.assoc fs_name filesystem_types in - cb.fs_cb_offset_is_free fs offset - -(* 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, (_, cb)) :: rest -> - try Some (cb.lvm_cb_probe 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 _, cb = List.assoc lvm_name lvm_types in - cb.lvm_cb_list_lvs devs - -let lvm_offset_is_free ({ lvm_plugin_id = lvm_name } as pv) offset = - let _, cb = List.assoc lvm_name lvm_types in - cb.lvm_cb_offset_is_free pv offset - -(*----------------------------------------------------------------------*) -(* Create machine description. *) -let open_machine name disks = - let disks = List.map ( - fun (name, path) -> - let dev = new block_device path disk_block_size (* XXX *) 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 - -(* Main scanning function for filesystems. *) -let scan_machine ({ m_disks = m_disks } as machine) = - let m_disks = List.map ( - fun ({ d_dev = dev } as disk) -> - let dev = (dev :> device) in - (* 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 :> device)) - | _ -> 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 } - -(*----------------------------------------------------------------------*) - -(* We describe the ownership of each part of the disk using a - * segment tree. http://en.wikipedia.org/wiki/Segment_tree - * - * Note that each part can (and usually is) owned multiple times - * (eg. by a filesystem and by the partition that the filesystem - * lies inside). Also, the segment tree is effectively read-only. - * We build it up as a final step given the flat list of segments - * identified by the algorithm in 'iter_over_machine'. - *) - -(* General binary tree type. Data 'a is stored in the leaves and 'b - * is stored in the nodes. - *) -type ('a,'b) binary_tree = - | Leaf of 'a - | Node of ('a,'b) binary_tree * 'b * ('a,'b) binary_tree - -(* This prints out the binary tree in graphviz dot format. *) -let print_binary_tree leaf_printer node_printer tree = - (* Assign a unique, fixed label to each node. *) - let label = - let i = ref 0 in - let hash = Hashtbl.create 13 in - fun node -> - try Hashtbl.find hash node - with Not_found -> - let i = incr i; !i in - let label = "n" ^ string_of_int i in - Hashtbl.add hash node label; - label - in - (* Recursively generate the graphviz file. *) - let rec print = function - | (Leaf a as leaf) -> - eprintf " %s [shape=box, label=\"%s\"];\n" - (label leaf) (leaf_printer a) - | (Node (left,b,right) as node) -> - eprintf " %s [label=\"%s\"];\n" - (label node) (node_printer b); - eprintf " %s -> %s [tailport=sw];\n" (label node) (label left); - eprintf " %s -> %s [tailport=se];\n" (label node) (label right); - print left; - print right; - in - eprintf "/* Use 'dot -Tpng foo.dot > foo.png' to convert to a png file. */\n"; - eprintf "digraph G {\n"; - print tree; - eprintf "}\n%!"; - -type owner = - [ `Filesystem of filesystem - | `Partitions of partitions - | `PhysicalVolume of pv ] - -(* A segment describes the owner of a range of disk addresses. *) -type segment = owner * int63 (* owner, owner offset *) - -type interval = int63 * int63 (* start point, end point (bytes) *) - -(* The special segment tree structure that we construct in create_ownership. *) -type segment_tree = - (interval * segment list, interval * segment list) binary_tree - -type ownership = - (device * (* block_device (disk) *) - segment_tree) list (* segment tree for this disk *) - -(* List of owned segments before we build the segment tree. *) -type ownership_list = - (device * (* block_device (disk) *) - (int63 * int63 * (* disk offset, size of segment *) - owner * int63 (* owner, owner offset *) - ) - ) list - -(* Ownership tables. *) -let create_ownership machine = - (* Iterate over all the things which can claim ownership of a - * disk block (filesystems, partitions, PVs). - *) - let rec iter_over_machine - ({m_disks = disks; m_lv_filesystems = lv_filesystems} as machine) = - - (* No segments to begin with. *) - let ownership = [] in - - (* Iterate over disks. *) - let ownership = - List.fold_left ( - fun ownership -> - function - | { d_content = (`Filesystem fs as owner) } -> - iter_over_filesystem machine ownership fs owner - | { d_content = (`Partitions parts as owner) } -> - iter_over_partitions machine ownership parts owner - | { d_content = (`PhysicalVolume pv as owner) } -> - iter_over_pv machine ownership pv owner - | { d_content = `Unknown } -> ownership - ) ownership disks in - - (* Iterate over LV filesystems. *) - let ownership = - List.fold_left ( - fun ownership (lv, fs) -> - let owner = `Filesystem fs in - iter_over_filesystem machine ownership fs owner - ) ownership lv_filesystems in - - ownership - - (* Iterate over the blocks in a single filesystem. *) - and iter_over_filesystem machine ownership {fs_dev = dev} owner = - iter_over_device machine ownership dev owner - - (* Iterate over the blocks in a set of partitions, then - * iterate over the contents of the partitions. - *) - and iter_over_partitions machine ownership - {parts = parts; parts_dev = parts_dev} owner = - let ownership = iter_over_device machine ownership parts_dev owner in - - let ownership = - List.fold_left ( - fun ownership -> - function - | { part_content = (`Filesystem fs as owner) } -> - iter_over_filesystem machine ownership fs owner - | { part_content = (`PhysicalVolume pv as owner) } -> - iter_over_pv machine ownership pv owner - | { part_content = `Unknown } -> ownership - ) ownership parts in - - ownership - - (* Iterate over the blocks in a PV. *) - and iter_over_pv machine ownership {pv_dev = dev} owner = - iter_over_device machine ownership dev owner - - (* Iterate over the blocks in a device, assigning ownership to 'owner' - * - * In reality (1): There can be several owners for each block, so we - * incrementally add ownership to the ownership_list (which eventually - * will be turned into a segment tree). - * In reality (2): Iterating over blocks would take ages and result - * in a very inefficient ownership representation. Instead we look - * at minimum contiguous extents. - *) - and iter_over_device { m_disks = disks } ownership dev owner = - let size = dev#size in - let disks = List.map (fun {d_dev = dev} -> (dev :> device)) disks in - - let rec loop ownership offset = - if offset < size then ( - let devs, extent = get_next_extent disks dev offset in - if devs = [] then - eprintf "warning: no device found under %s\n" - (string_of_owner owner); - let ownership = - List.fold_left ( - fun ownership (disk, disk_offset) -> - let elem = disk, (disk_offset, extent, owner, offset) in - elem :: ownership - ) ownership devs in - loop ownership (offset +^ extent) - ) - else ownership - in - loop ownership ~^0 - - (* Return the length of the next contiguous region in the device starting - * at the given byte offset. Also return the underlying block device(s) - * if there is one. - *) - and get_next_extent disks (dev : device) offset = - let this_extent = dev#contiguous offset in - - (* If this disk is a block_device (a member of the 'disks' list) - * then we've hit the bottom layer of devices, so just return it. - *) - if List.memq dev disks then - [dev, offset], this_extent - else ( - let blocksize = dev#blocksize in - let block = offset /^ blocksize in - let offset_in_block = offset -^ block *^ blocksize in - - (* Map from this block to the devices one layer down. *) - let devs = dev#map_block block in - - (* Get the real device offsets, adding the offset from start of block. *) - let devs = - List.map - (fun (dev, dev_offset) -> dev, dev_offset +^ offset_in_block) - devs in - - let devs = - List.map - (fun (dev, dev_offset) -> - get_next_extent disks dev dev_offset) - devs in - - (* Work out the minimum contiguous extent from this offset. *) - let devs, extent = - let extents = List.map snd devs in - let devs = List.concat (List.map fst devs) in - let extent = List.fold_left min this_extent extents in - devs, extent in - - devs, extent - ) - - and string_of_owner = function - | `Filesystem {fs_plugin_id = fs_plugin_id; fs_dev = fs_dev} -> - sprintf "%s(%s)" fs_dev#name fs_plugin_id - | `PhysicalVolume { pv_uuid = pv_uuid } -> - "PV:" ^ pv_uuid - | `Partitions { parts_plugin_id = parts_plugin_id } -> - parts_plugin_id - in - - (* Build the list of segments. *) - let ownership : ownership_list = iter_over_machine machine in - - (* Group the segments together by disk. *) - let ownership = - let ownership = List.sort ownership in - group_by ownership in - - (* If debugging, print the segments that we found. *) - if !debug then ( - List.iter ( - fun (disk, segments) -> - eprintf "ownership segment list of %s %s:\n" machine.m_name disk#name; - List.iter ( - fun (disk_offset, size, owner, owner_offset) -> - let blocksize = disk#blocksize in - let disk_offset_in_blocks, disk_offset_in_block = - disk_offset /^ blocksize, disk_offset %^ blocksize in - let size_in_blocks, size_in_block = - size /^ blocksize, size %^ blocksize in - - eprintf " %s[%s:%s] %s[%s:%s] %s@%s\n" - (Int63.to_string disk_offset) - (Int63.to_string disk_offset_in_blocks) - (Int63.to_string disk_offset_in_block) - (Int63.to_string size) - (Int63.to_string size_in_blocks) - (Int63.to_string size_in_block) - (string_of_owner owner) - (Int63.to_string owner_offset) - ) segments - ) ownership - ); - - (* Build the segment tree from the ownership list (of segments). - * For an explanation of this process see: - * http://en.wikipedia.org/wiki/Segment_tree - *) - let ownership = - List.map ( - fun (disk, segments) -> - (* Construct the list of distinct endpoints. *) - let eps = - List.map - (fun (start, size, _, _) -> [start; start +^ size]) - segments in - let eps = sort_uniq (List.concat eps) in - - (* Construct the elementary intervals. *) - let elints = - let elints, lastpoint = - List.fold_left ( - fun (elints, prevpoint) point -> - ((point, point) :: (prevpoint, point) :: elints), point - ) ([], Int63.min_int) eps in - let elints = (lastpoint, Int63.max_int) :: elints in - List.rev elints in - - if !debug then ( - eprintf "elementary intervals for %s (%d in total):\n" - disk#name (List.length elints); - List.iter ( - fun (startpoint, endpoint) -> - eprintf " %s %s\n" - (Int63.to_string startpoint) (Int63.to_string endpoint) - ) elints - ); - - (* Construct the binary tree of elementary intervals. *) - let tree = - (* Each elementary interval becomes a leaf. *) - let elints = List.map (fun elint -> Leaf elint) elints in - (* Recursively build this into a binary tree. *) - let rec make_layer = function - | [] -> [] - | ([_] as x) -> x - (* Turn pairs of leaves at the bottom level into nodes. *) - | (Leaf _ as a) :: (Leaf _ as b) :: xs -> - let xs = make_layer xs in - Node (a, (), b) :: xs - (* Turn pairs of nodes at higher levels into nodes. *) - | (Node _ as left) :: ((Node _|Leaf _) as right) :: xs -> - let xs = make_layer xs in - Node (left, (), right) :: xs - | Leaf _ :: _ -> assert false (* never happens??? (I think) *) - in - let rec loop = function - | [] -> assert false - | [x] -> x - | xs -> loop (make_layer xs) - in - loop elints in - - if !debug then ( - let leaf_printer (startpoint, endpoint) = - sprintf "%s-%s" - (Int63.to_string startpoint) (Int63.to_string endpoint) - in - let node_printer () = "" in - print_binary_tree leaf_printer node_printer tree - ); - - (* Insert the segments into the tree one by one. *) - let tree = - (* For each node/leaf in the tree, add its interval and an - * empty list which will be used to store the segments. - *) - let rec interval_tree = function - | Leaf elint -> Leaf (elint, []) - | Node (left, (), right) -> - let left = interval_tree left in - let right = interval_tree right in - let (leftstart, _) = interval_of_node left in - let (_, rightend) = interval_of_node right in - let interval = leftstart, rightend in - Node (left, (interval, []), right) - and interval_of_node = function - | Leaf (elint, _) -> elint - | Node (_, (interval, _), _) -> interval - in - - let tree = interval_tree tree in - (* This should always be true: *) - assert (interval_of_node tree = (Int63.min_int, Int63.max_int)); - - (* "Contained in" operator. - * 'a <-< b' iff 'a' is a subinterval of 'b'. - * |<---- a ---->| - * |<----------- b ----------->| - *) - let (<-<) (a1, a2) (b1, b2) = b1 <= a1 && a2 <= b2 in - - (* "Intersects" operator. - * 'a /\ b' iff intervals 'a' and 'b' overlap, eg: - * |<---- a ---->| - * |<----------- b ----------->| - *) - let ( /\ ) (a1, a2) (b1, b2) = a2 > b1 || b2 > a1 in - - let rec insert_segment tree segment = - let start, size, owner, owner_offset = segment in - let seginterval = start, start +^ size in - let seg = owner, owner_offset in - - match tree with - (* Test if we should insert into this leaf or node: *) - | Leaf (interval, segs) when interval <-< seginterval -> - Leaf (interval, seg :: segs) - | Node (left, (interval, segs), right) - when interval <-< seginterval -> - Node (left, (interval, seg :: segs), right) - - | (Leaf _) as leaf -> leaf - - (* Else, should we insert into left or right subtrees? *) - | Node (left, i, right) -> - let left = - if seginterval /\ interval_of_node left then - insert_segment left segment - else - left in - let right = - if seginterval /\ interval_of_node right then - insert_segment right segment - else - right in - Node (left, i, right) - in - let tree = List.fold_left insert_segment tree segments in - tree in - - if !debug then ( - let printer ((sp, ep), segments) = - sprintf "[%s-%s] " (Int63.to_string sp) (Int63.to_string ep) ^ - String.concat ";" - (List.map (fun (owner,_) -> string_of_owner owner) - segments) - in - print_binary_tree printer printer tree - ); - (disk, tree) - ) ownership in - - (* Return the ownership structure. *) - ownership - -let get_owners_lookup machine ownership (disk : block_device) = - (* Get the correct tree. *) - let tree = List.assoc (disk :> device) ownership in - - fun offset -> - (* Warning: This 'hot' code was carefully optimized based on - * feedback from 'gprof'. Avoid fiddling with it. - *) - let rec query = function - | Leaf (_, segments) -> segments - - (* Try to avoid expensive '@' operator if node segments is empty: *) - | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left), - (_, []), - right) -> - let subsegments = - if offset < leftend then query left else query right in - subsegments - - (* ... or a singleton: *) - | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left), - (_, [segment]), - right) -> - let subsegments = - if offset < leftend then query left else query right in - segment :: subsegments - - (* Normal recursive case: *) - | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left), - (_, segments), - right) -> - let subsegments = - if offset < leftend then query left else query right in - segments @ subsegments - in - let owners = query tree in - - List.map ( - fun (owner, owner_offset) -> (owner, offset -^ owner_offset) - ) owners - -(* Find out if a disk offset is free. - * Current algorithm just checks that at least one owner says - * it is free. We could be smarter about this. +(* This just forces the plug-ins to get loaded when anyone references + * this library. You need one line for each plug-in. *) -let offset_is_free owners = - List.exists ( - function - | `Filesystem fs, offset -> fs_offset_is_free fs offset - | `Partitions parts, offset -> parts_offset_is_free parts offset - | `PhysicalVolume pv, offset -> lvm_offset_is_free pv offset - ) owners +let _ = Diskimage_ext2.id +let _ = Diskimage_linux_swap.id +let _ = Diskimage_linux_swsuspend.id +let _ = Diskimage_lvm2.id +let _ = Diskimage_mbr.id diff --git a/lib/diskimage.mli b/lib/diskimage.mli index 4eab561..f16703c 100644 --- a/lib/diskimage.mli +++ b/lib/diskimage.mli @@ -202,7 +202,7 @@ and disk_content = ] and partitions = { - parts_plugin_id : parts_plugin_id; (** Partitioning scheme. *) + parts_cb : partitioner_callbacks; (** Partitioning scheme. *) parts_dev : device; (** Partitions (whole) device. *) parts : partition list; (** Partitions. *) } @@ -222,7 +222,7 @@ and partition_content = ] and filesystem = { - fs_plugin_id : fs_plugin_id; (** Filesystem type. *) + fs_cb : filesystem_callbacks; (** Filesystem type. *) fs_dev : device; (** Device containing the filesystem. *) fs_blocksize : Int63.t; (** Block size (bytes). *) fs_blocks_total : Int63.t; (** Total blocks. *) @@ -238,7 +238,7 @@ and filesystem = { (** A filesystem, with superblock contents. *) and pv = { - lvm_plugin_id : lvm_plugin_id; (** The LVM plug-in which detected + pv_cb : lvm_callbacks; (** The LVM plug-in which detected this. *) pv_dev : device; (** Device covering whole PV. *) pv_uuid : string; (** UUID. *) @@ -248,18 +248,17 @@ and lv = { } (** Physical and logical volumes as used by LVM plug-ins. *) -and parts_plugin_id -and fs_plugin_id -and lvm_plugin_id - (** Opaque IDs used to refer to the plug-ins. *) - -val name_of_parts : parts_plugin_id -> string -val name_of_filesystem : fs_plugin_id -> string -val name_of_lvm : lvm_plugin_id -> string - (** Convert plug-in IDs to printable strings. *) +and partitioner_callbacks +and filesystem_callbacks +and lvm_callbacks (** {2 Functions} *) +val name_of_filesystem : filesystem -> string + (** [name_of_filesystem fs] returns a printable name for + the filesystem. + *) + (** {3 Create 'machine'} *) val open_machine : string -> (string * string) list -> machine diff --git a/lib/diskimage_ext2.ml b/lib/diskimage_ext2.ml index ea020b5..ade7940 100644 --- a/lib/diskimage_ext2.ml +++ b/lib/diskimage_ext2.ml @@ -22,7 +22,7 @@ open Unix open Printf -open Diskimage_utils +open Diskimage_impl open Int63.Operators @@ -31,11 +31,11 @@ let ( -* ) = Int32.sub let ( ** ) = Int32.mul let ( /* ) = Int32.div -let plugin_id = "ext2" +let id = "ext2" let superblock_offset = ~^1024 let superblock_len = ~^1024 -let probe dev = +let rec probe dev = (* Load the superblock. *) let bits = dev#read_bitstring superblock_offset superblock_len in @@ -127,7 +127,7 @@ let probe dev = let fs_dev = new blocksize_overlay block_size dev in { - fs_plugin_id = plugin_id; + fs_cb = callbacks; fs_dev = fs_dev; fs_blocksize = block_size; @@ -151,9 +151,13 @@ let probe dev = | { _ } -> raise Not_found (* Not an EXT2/3 superblock. *) -let offset_is_free _ _ = false +and offset_is_free _ _ = false -let callbacks = { - fs_cb_probe = probe; +and callbacks = { + fs_cb_name = id; + fs_cb_printable_name = "Linux ext2/3"; fs_cb_offset_is_free = offset_is_free; } + +(* Register the plugin. *) +let () = register_plugin ~filesystem:probe id diff --git a/lib/diskimage_ext2.mli b/lib/diskimage_ext2.mli index a5b8426..52995b3 100644 --- a/lib/diskimage_ext2.mli +++ b/lib/diskimage_ext2.mli @@ -19,5 +19,4 @@ (**/**) -val plugin_id : string -val callbacks : Diskimage_utils.fs_cb +val id : string diff --git a/lib/diskimage_impl.ml b/lib/diskimage_impl.ml new file mode 100644 index 0000000..18af635 --- /dev/null +++ b/lib/diskimage_impl.ml @@ -0,0 +1,983 @@ +(* 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 ExtList +open Printf +open Unix + +open Int63.Operators + +let debug = ref false + +(* Use as the natural block size for disk images, but really we should + * use the 'blockdev -getbsz' command to find the real block size. + *) +let disk_block_size = ~^512 + +class virtual device = +object (self) + method virtual size : int63 + method virtual name : string + method virtual blocksize : int63 + method virtual map_block : int63 -> (device * int63) list + method virtual contiguous : Int63.t -> Int63.t + + (* Block-based read. Inefficient so normally overridden in subclasses. *) + method read offset len = + if offset < ~^0 || len < ~^0 then + invalid_arg "device: read: negative offset or length"; + + let blocksize = self#blocksize in + + (* Break the request into blocks. + * Find the first and last blocks of this request. + *) + let first_blk = offset /^ blocksize in + let offset_in_first_blk = offset -^ first_blk *^ blocksize in + let last_blk = (offset +^ len -^ ~^1) /^ blocksize in + + (* Buffer for the result. *) + let buf = Buffer.create (Int63.to_int len) in + + let not_mapped_error () = invalid_arg "device: read: block not mapped" in + + (* Copy the first block (partial). *) + (match self#map_block first_blk with + | [] -> not_mapped_error () + | (dev, base) :: _ -> + let len = + min len (blocksize -^ offset_in_first_blk) in + let str = dev#read (base +^ offset_in_first_blk) len in + Buffer.add_string buf str + ); + + (* Copy the middle blocks. *) + let rec loop blk = + if blk < last_blk then ( + (match self#map_block blk with + | [] -> not_mapped_error () + | (dev, base) :: _ -> + let str = dev#read ~^0 self#blocksize in + Buffer.add_string buf str + ); + loop (Int63.succ blk) + ) + in + loop (Int63.succ first_blk); + + (* Copy the last block (partial). *) + if first_blk < last_blk then ( + match self#map_block last_blk with + | [] -> not_mapped_error () + | (dev, base) :: _ -> + let len = (offset +^ len) -^ last_blk *^ blocksize in + let str = dev#read ~^0 len in + Buffer.add_string buf str + ); + + assert (Int63.to_int len = Buffer.length buf); + Buffer.contents buf + + (* 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, String.length str lsl 3) +end + +(* A concrete device which just direct-maps a file or /dev device. *) +class block_device filename blocksize = + let fd = openfile filename [ O_RDONLY ] 0 in + let size = Int63.of_int64 (LargeFile.fstat fd).LargeFile.st_size in +object (self) + inherit device + method read offset len = + let offset = Int63.to_int64 offset in + let len = Int63.to_int len in + ignore (LargeFile.lseek fd offset SEEK_SET); + let str = String.make len '\000' in + ignore (read fd str 0 len); + str + method size = size + method name = filename + method blocksize = blocksize + method map_block _ = [] + method contiguous offset = + size -^ offset + method close () = close fd +end + +(* A linear offset/size from an underlying device. *) +class offset_device name start size blocksize (dev : device) = +object + inherit device + method name = name + method size = size + method read offset len = + if offset < ~^0 || len < ~^0 || offset +^ len > size then + invalid_arg ( + sprintf "%s: tried to read outside device boundaries (%s/%s/%s)" + name (Int63.to_string offset) (Int63.to_string len) + (Int63.to_string size) + ); + dev#read (start+^offset) len + method blocksize = blocksize + method map_block i = [dev, i *^ blocksize +^ start] + method contiguous offset = + size -^ offset +end + +(* A device with just a modified block size. *) +class blocksize_overlay new_blocksize (dev : device) = +object + inherit device + method name = dev#name + method size = dev#size + method read = dev#read + method blocksize = new_blocksize + method map_block new_blk = + let orig_blk = new_blk *^ new_blocksize /^ dev#blocksize in + dev#map_block orig_blk + method contiguous offset = dev#size -^ offset +end + +(* The null device. Any attempt to read generates an error. *) +let null_device : device = +object + inherit device + method read _ _ = assert false + method size = ~^0 + method name = "null" + method blocksize = ~^1 + method map_block _ = assert false + method contiguous _ = ~^0 +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 : block_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_cb : partitioner_callbacks; (* Partitioning scheme. *) + parts_dev : device; (* Partitions (whole) device. *) + 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_cb : filesystem_callbacks; (* Filesystem. *) + fs_dev : device; (* Device containing the filesystem. *) + fs_blocksize : int63; (* Block size (bytes). *) + fs_blocks_total : int63; (* Total blocks. *) + fs_is_swap : bool; (* If swap, following not valid. *) + fs_blocks_reserved : int63; (* Blocks reserved for super-user. *) + fs_blocks_avail : int63; (* Blocks free (available). *) + fs_blocks_used : int63; (* Blocks in use. *) + fs_inodes_total : int63; (* Total inodes. *) + fs_inodes_reserved : int63; (* Inodes reserved for super-user. *) + fs_inodes_avail : int63; (* Inodes free (available). *) + fs_inodes_used : int63; (* Inodes in use. *) +} + +(* Physical volumes. *) +and pv = { + pv_cb : lvm_callbacks; (* The LVM plug-in. *) + pv_dev : device; (* Device covering whole PV. *) + pv_uuid : string; (* UUID. *) +} + +(* Logical volumes. *) +and lv = { + lv_dev : device; (* Logical volume device. *) +} + +(* Tables of callbacks. *) +and partitioner_probe = device -> partitions + +and partitioner_callbacks = { + parts_cb_name : string; + parts_cb_offset_is_free : partitions -> Int63.t -> bool; +} + +and filesystem_probe = device -> filesystem + +and filesystem_callbacks = { + fs_cb_name : string; + fs_cb_printable_name : string; + fs_cb_offset_is_free : filesystem -> Int63.t -> bool; +} + +and lvm_probe = device -> pv + +and lvm_callbacks = { + lvm_cb_name : string; + lvm_cb_list_lvs : pv list -> lv list; + lvm_cb_offset_is_free : pv -> Int63.t -> bool; +} + +let name_of_filesystem { fs_cb = { fs_cb_printable_name = name } } = name + +(*----------------------------------------------------------------------*) +(* Helper functions. *) + +(* 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 uniq ?(cmp = Pervasives.compare) = function + | [] -> [] + | [x] -> [x] + | x :: y :: xs when cmp x y = 0 -> + uniq (x :: xs) + | x :: y :: xs -> + x :: uniq (y :: xs) + +let sort_uniq ?cmp xs = + let xs = ExtList.List.sort ?cmp xs in + let xs = uniq ?cmp xs in + xs + +let rec range a b = + if a < b then a :: range (a+1) b + else [] + +(*----------------------------------------------------------------------*) +(* The plug-ins. *) + +let partitioners = ref [] +let filesystems = ref [] +let lvms = ref [] + +let register_plugin ?partitioner ?filesystem ?lvm id = + (match partitioner with + | None -> () + | Some probe -> partitioners := !partitioners @ [id, probe] + ); + (match filesystem with + | None -> () + | Some probe -> filesystems := !filesystems @ [id, probe] + ); + (match lvm with + | None -> () + | Some probe -> lvms := !lvms @ [id, probe] + ) + +(* 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 + | (_, probe) :: rest -> + try Some (probe dev) + with Not_found -> loop rest + in + let r = loop !partitioners in + if !debug then ( + match r with + | None -> eprintf "no partitions found on %s\n%!" dev#name + | Some { parts_cb = { parts_cb_name = name }; parts = parts } -> + eprintf "found %d %s partitions on %s\n" + (List.length parts) name dev#name + ); + 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 + | (_, probe) :: rest -> + try Some (probe dev) + with Not_found -> loop rest + in + let r = loop !filesystems 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%!" fs.fs_cb.fs_cb_name + ); + r + +(* Probe a device for a PV. Returns [Some pv] 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 + | (_, probe) :: rest -> + try Some (probe dev) + with Not_found -> loop rest + in + let r = loop !lvms in + if !debug then ( + match r with + | None -> eprintf "no PV found on %s\n%!" dev#name + | Some { pv_cb = { lvm_cb_name = name } } -> + eprintf "%s contains a %s PV\n%!" dev#name name + ); + r + +(*----------------------------------------------------------------------*) +(* Create machine description. *) +let open_machine name disks = + let disks = List.map ( + fun (name, path) -> + let dev = new block_device path disk_block_size (* XXX *) 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 + +(* Main scanning function for filesystems. *) +let scan_machine ({ m_disks = m_disks } as machine) = + let m_disks = List.map ( + fun ({ d_dev = dev } as disk) -> + let dev = (dev :> device) in + (* 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 pv -> + { disk with d_content = `PhysicalVolume pv } + | 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_content = `PhysicalVolume pv } -> Some pv + | _ -> None + ) m_disks in + let pvs_on_partitions = List.map ( + function + | { d_content = `Partitions { parts = parts } } -> + List.filter_map ( + function + | { part_content = `PhysicalVolume pv } -> Some pv + | _ -> 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 LVM plug-in ID. + *) + let lvs = + List.map (fun ({pv_cb = {lvm_cb_name = name}} as pv) -> name, pv) lvs in + let lvs = List.sort lvs in + let lvs = group_by lvs in + + let lvs = List.map (fun (name, pvs) -> + let pv = List.hd pvs in + pv.pv_cb.lvm_cb_list_lvs pvs) 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 } + +(*----------------------------------------------------------------------*) + +(* We describe the ownership of each part of the disk using a + * segment tree. http://en.wikipedia.org/wiki/Segment_tree + * + * Note that each part can (and usually is) owned multiple times + * (eg. by a filesystem and by the partition that the filesystem + * lies inside). Also, the segment tree is effectively read-only. + * We build it up as a final step given the flat list of segments + * identified by the algorithm in 'iter_over_machine'. + *) + +(* General binary tree type. Data 'a is stored in the leaves and 'b + * is stored in the nodes. + *) +type ('a,'b) binary_tree = + | Leaf of 'a + | Node of ('a,'b) binary_tree * 'b * ('a,'b) binary_tree + +(* This prints out the binary tree in graphviz dot format. *) +let print_binary_tree leaf_printer node_printer tree = + (* Assign a unique, fixed label to each node. *) + let label = + let i = ref 0 in + let hash = Hashtbl.create 13 in + fun node -> + try Hashtbl.find hash node + with Not_found -> + let i = incr i; !i in + let label = "n" ^ string_of_int i in + Hashtbl.add hash node label; + label + in + (* Recursively generate the graphviz file. *) + let rec print = function + | (Leaf a as leaf) -> + eprintf " %s [shape=box, label=\"%s\"];\n" + (label leaf) (leaf_printer a) + | (Node (left,b,right) as node) -> + eprintf " %s [label=\"%s\"];\n" + (label node) (node_printer b); + eprintf " %s -> %s [tailport=sw];\n" (label node) (label left); + eprintf " %s -> %s [tailport=se];\n" (label node) (label right); + print left; + print right; + in + eprintf "/* Use 'dot -Tpng foo.dot > foo.png' to convert to a png file. */\n"; + eprintf "digraph G {\n"; + print tree; + eprintf "}\n%!"; + +type owner = + [ `Filesystem of filesystem + | `Partitions of partitions + | `PhysicalVolume of pv ] + +(* A segment describes the owner of a range of disk addresses. *) +type segment = owner * int63 (* owner, owner offset *) + +type interval = int63 * int63 (* start point, end point (bytes) *) + +(* The special segment tree structure that we construct in create_ownership. *) +type segment_tree = + (interval * segment list, interval * segment list) binary_tree + +type ownership = + (device * (* block_device (disk) *) + segment_tree) list (* segment tree for this disk *) + +(* List of owned segments before we build the segment tree. *) +type ownership_list = + (device * (* block_device (disk) *) + (int63 * int63 * (* disk offset, size of segment *) + owner * int63 (* owner, owner offset *) + ) + ) list + +(* Ownership tables. *) +let create_ownership machine = + (* Iterate over all the things which can claim ownership of a + * disk block (filesystems, partitions, PVs). + *) + let rec iter_over_machine + ({m_disks = disks; m_lv_filesystems = lv_filesystems} as machine) = + + (* No segments to begin with. *) + let ownership = [] in + + (* Iterate over disks. *) + let ownership = + List.fold_left ( + fun ownership -> + function + | { d_content = (`Filesystem fs as owner) } -> + iter_over_filesystem machine ownership fs owner + | { d_content = (`Partitions parts as owner) } -> + iter_over_partitions machine ownership parts owner + | { d_content = (`PhysicalVolume pv as owner) } -> + iter_over_pv machine ownership pv owner + | { d_content = `Unknown } -> ownership + ) ownership disks in + + (* Iterate over LV filesystems. *) + let ownership = + List.fold_left ( + fun ownership (lv, fs) -> + let owner = `Filesystem fs in + iter_over_filesystem machine ownership fs owner + ) ownership lv_filesystems in + + ownership + + (* Iterate over the blocks in a single filesystem. *) + and iter_over_filesystem machine ownership {fs_dev = dev} owner = + iter_over_device machine ownership dev owner + + (* Iterate over the blocks in a set of partitions, then + * iterate over the contents of the partitions. + *) + and iter_over_partitions machine ownership + {parts = parts; parts_dev = parts_dev} owner = + let ownership = iter_over_device machine ownership parts_dev owner in + + let ownership = + List.fold_left ( + fun ownership -> + function + | { part_content = (`Filesystem fs as owner) } -> + iter_over_filesystem machine ownership fs owner + | { part_content = (`PhysicalVolume pv as owner) } -> + iter_over_pv machine ownership pv owner + | { part_content = `Unknown } -> ownership + ) ownership parts in + + ownership + + (* Iterate over the blocks in a PV. *) + and iter_over_pv machine ownership {pv_dev = dev} owner = + iter_over_device machine ownership dev owner + + (* Iterate over the blocks in a device, assigning ownership to 'owner' + * + * In reality (1): There can be several owners for each block, so we + * incrementally add ownership to the ownership_list (which eventually + * will be turned into a segment tree). + * In reality (2): Iterating over blocks would take ages and result + * in a very inefficient ownership representation. Instead we look + * at minimum contiguous extents. + *) + and iter_over_device { m_disks = disks } ownership dev owner = + let size = dev#size in + let disks = List.map (fun {d_dev = dev} -> (dev :> device)) disks in + + let rec loop ownership offset = + if offset < size then ( + let devs, extent = get_next_extent disks dev offset in + if devs = [] then + eprintf "warning: no device found under %s\n" + (string_of_owner owner); + let ownership = + List.fold_left ( + fun ownership (disk, disk_offset) -> + let elem = disk, (disk_offset, extent, owner, offset) in + elem :: ownership + ) ownership devs in + loop ownership (offset +^ extent) + ) + else ownership + in + loop ownership ~^0 + + (* Return the length of the next contiguous region in the device starting + * at the given byte offset. Also return the underlying block device(s) + * if there is one. + *) + and get_next_extent disks (dev : device) offset = + let this_extent = dev#contiguous offset in + + (* If this disk is a block_device (a member of the 'disks' list) + * then we've hit the bottom layer of devices, so just return it. + *) + if List.memq dev disks then + [dev, offset], this_extent + else ( + let blocksize = dev#blocksize in + let block = offset /^ blocksize in + let offset_in_block = offset -^ block *^ blocksize in + + (* Map from this block to the devices one layer down. *) + let devs = dev#map_block block in + + (* Get the real device offsets, adding the offset from start of block. *) + let devs = + List.map + (fun (dev, dev_offset) -> dev, dev_offset +^ offset_in_block) + devs in + + let devs = + List.map + (fun (dev, dev_offset) -> + get_next_extent disks dev dev_offset) + devs in + + (* Work out the minimum contiguous extent from this offset. *) + let devs, extent = + let extents = List.map snd devs in + let devs = List.concat (List.map fst devs) in + let extent = List.fold_left min this_extent extents in + devs, extent in + + devs, extent + ) + + and string_of_owner = function + | `Filesystem {fs_cb = {fs_cb_name = name}; fs_dev = fs_dev} -> + sprintf "%s(%s)" fs_dev#name name + | `PhysicalVolume { pv_uuid = pv_uuid } -> + "PV:" ^ pv_uuid + | `Partitions { parts_cb = {parts_cb_name = name} } -> + name + in + + (* Build the list of segments. *) + let ownership : ownership_list = iter_over_machine machine in + + (* Group the segments together by disk. *) + let ownership = + let ownership = List.sort ownership in + group_by ownership in + + (* If debugging, print the segments that we found. *) + if !debug then ( + List.iter ( + fun (disk, segments) -> + eprintf "ownership segment list of %s %s:\n" machine.m_name disk#name; + List.iter ( + fun (disk_offset, size, owner, owner_offset) -> + let blocksize = disk#blocksize in + let disk_offset_in_blocks, disk_offset_in_block = + disk_offset /^ blocksize, disk_offset %^ blocksize in + let size_in_blocks, size_in_block = + size /^ blocksize, size %^ blocksize in + + eprintf " %s[%s:%s] %s[%s:%s] %s@%s\n" + (Int63.to_string disk_offset) + (Int63.to_string disk_offset_in_blocks) + (Int63.to_string disk_offset_in_block) + (Int63.to_string size) + (Int63.to_string size_in_blocks) + (Int63.to_string size_in_block) + (string_of_owner owner) + (Int63.to_string owner_offset) + ) segments + ) ownership + ); + + (* Build the segment tree from the ownership list (of segments). + * For an explanation of this process see: + * http://en.wikipedia.org/wiki/Segment_tree + *) + let ownership = + List.map ( + fun (disk, segments) -> + (* Construct the list of distinct endpoints. *) + let eps = + List.map + (fun (start, size, _, _) -> [start; start +^ size]) + segments in + let eps = sort_uniq (List.concat eps) in + + (* Construct the elementary intervals. *) + let elints = + let elints, lastpoint = + List.fold_left ( + fun (elints, prevpoint) point -> + ((point, point) :: (prevpoint, point) :: elints), point + ) ([], Int63.min_int) eps in + let elints = (lastpoint, Int63.max_int) :: elints in + List.rev elints in + + if !debug then ( + eprintf "elementary intervals for %s (%d in total):\n" + disk#name (List.length elints); + List.iter ( + fun (startpoint, endpoint) -> + eprintf " %s %s\n" + (Int63.to_string startpoint) (Int63.to_string endpoint) + ) elints + ); + + (* Construct the binary tree of elementary intervals. *) + let tree = + (* Each elementary interval becomes a leaf. *) + let elints = List.map (fun elint -> Leaf elint) elints in + (* Recursively build this into a binary tree. *) + let rec make_layer = function + | [] -> [] + | ([_] as x) -> x + (* Turn pairs of leaves at the bottom level into nodes. *) + | (Leaf _ as a) :: (Leaf _ as b) :: xs -> + let xs = make_layer xs in + Node (a, (), b) :: xs + (* Turn pairs of nodes at higher levels into nodes. *) + | (Node _ as left) :: ((Node _|Leaf _) as right) :: xs -> + let xs = make_layer xs in + Node (left, (), right) :: xs + | Leaf _ :: _ -> assert false (* never happens??? (I think) *) + in + let rec loop = function + | [] -> assert false + | [x] -> x + | xs -> loop (make_layer xs) + in + loop elints in + + if !debug then ( + let leaf_printer (startpoint, endpoint) = + sprintf "%s-%s" + (Int63.to_string startpoint) (Int63.to_string endpoint) + in + let node_printer () = "" in + print_binary_tree leaf_printer node_printer tree + ); + + (* Insert the segments into the tree one by one. *) + let tree = + (* For each node/leaf in the tree, add its interval and an + * empty list which will be used to store the segments. + *) + let rec interval_tree = function + | Leaf elint -> Leaf (elint, []) + | Node (left, (), right) -> + let left = interval_tree left in + let right = interval_tree right in + let (leftstart, _) = interval_of_node left in + let (_, rightend) = interval_of_node right in + let interval = leftstart, rightend in + Node (left, (interval, []), right) + and interval_of_node = function + | Leaf (elint, _) -> elint + | Node (_, (interval, _), _) -> interval + in + + let tree = interval_tree tree in + (* This should always be true: *) + assert (interval_of_node tree = (Int63.min_int, Int63.max_int)); + + (* "Contained in" operator. + * 'a <-< b' iff 'a' is a subinterval of 'b'. + * |<---- a ---->| + * |<----------- b ----------->| + *) + let (<-<) (a1, a2) (b1, b2) = b1 <= a1 && a2 <= b2 in + + (* "Intersects" operator. + * 'a /\ b' iff intervals 'a' and 'b' overlap, eg: + * |<---- a ---->| + * |<----------- b ----------->| + *) + let ( /\ ) (a1, a2) (b1, b2) = a2 > b1 || b2 > a1 in + + let rec insert_segment tree segment = + let start, size, owner, owner_offset = segment in + let seginterval = start, start +^ size in + let seg = owner, owner_offset in + + match tree with + (* Test if we should insert into this leaf or node: *) + | Leaf (interval, segs) when interval <-< seginterval -> + Leaf (interval, seg :: segs) + | Node (left, (interval, segs), right) + when interval <-< seginterval -> + Node (left, (interval, seg :: segs), right) + + | (Leaf _) as leaf -> leaf + + (* Else, should we insert into left or right subtrees? *) + | Node (left, i, right) -> + let left = + if seginterval /\ interval_of_node left then + insert_segment left segment + else + left in + let right = + if seginterval /\ interval_of_node right then + insert_segment right segment + else + right in + Node (left, i, right) + in + let tree = List.fold_left insert_segment tree segments in + tree in + + if !debug then ( + let printer ((sp, ep), segments) = + sprintf "[%s-%s] " (Int63.to_string sp) (Int63.to_string ep) ^ + String.concat ";" + (List.map (fun (owner,_) -> string_of_owner owner) + segments) + in + print_binary_tree printer printer tree + ); + (disk, tree) + ) ownership in + + (* Return the ownership structure. *) + ownership + +let get_owners_lookup machine ownership (disk : block_device) = + (* Get the correct tree. *) + let tree = List.assoc (disk :> device) ownership in + + fun offset -> + (* Warning: This 'hot' code was carefully optimized based on + * feedback from 'gprof'. Avoid fiddling with it. + *) + let rec query = function + | Leaf (_, segments) -> segments + + (* Try to avoid expensive '@' operator if node segments is empty: *) + | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left), + (_, []), + right) -> + let subsegments = + if offset < leftend then query left else query right in + subsegments + + (* ... or a singleton: *) + | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left), + (_, [segment]), + right) -> + let subsegments = + if offset < leftend then query left else query right in + segment :: subsegments + + (* Normal recursive case: *) + | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left), + (_, segments), + right) -> + let subsegments = + if offset < leftend then query left else query right in + segments @ subsegments + in + let owners = query tree in + + List.map ( + fun (owner, owner_offset) -> (owner, offset -^ owner_offset) + ) owners + +(* Find out if a disk offset is free. + * Current algorithm just checks that at least one owner says + * it is free. We could be smarter about this. + *) +let offset_is_free owners = + List.exists ( + function + | `Filesystem fs, offset -> + fs.fs_cb.fs_cb_offset_is_free fs offset + | `Partitions parts, offset -> + parts.parts_cb.parts_cb_offset_is_free parts offset + | `PhysicalVolume pv, offset -> + pv.pv_cb.lvm_cb_offset_is_free pv offset + ) owners diff --git a/lib/diskimage_utils.mli b/lib/diskimage_impl.mli similarity index 77% rename from lib/diskimage_utils.mli rename to lib/diskimage_impl.mli index 07179d8..26dd555 100644 --- a/lib/diskimage_utils.mli +++ b/lib/diskimage_impl.mli @@ -16,6 +16,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Don't use the functions and types in here directly. The safe ones + * are reexported through the Diskimage module, see diskimage.mli. + *) + (**/**) val debug : bool ref @@ -90,7 +94,7 @@ and disk_content = ] and partitions = { - parts_plugin_id : parts_plugin_id; + parts_cb : partitioner_callbacks; parts_dev : device; parts : partition list; } @@ -109,7 +113,7 @@ and partition_content = ] and filesystem = { - fs_plugin_id : fs_plugin_id; + fs_cb : filesystem_callbacks; fs_dev : device; fs_blocksize : Int63.t; fs_blocks_total : Int63.t; @@ -124,7 +128,7 @@ and filesystem = { } and pv = { - lvm_plugin_id : lvm_plugin_id; + pv_cb : lvm_callbacks; pv_dev : device; pv_uuid : string; } @@ -132,28 +136,47 @@ and lv = { lv_dev : device; } -and parts_plugin_id = string -and fs_plugin_id = string -and lvm_plugin_id = string - (** {2 Table of callbacks from each type of plug-in} *) -type parts_cb = { - parts_cb_probe : device -> partitions; +and partitioner_probe = device -> partitions + +and partitioner_callbacks = { + parts_cb_name : string; parts_cb_offset_is_free : partitions -> Int63.t -> bool; } -type fs_cb = { - fs_cb_probe : device -> filesystem; +and filesystem_probe = device -> filesystem + +and filesystem_callbacks = { + fs_cb_name : string; + fs_cb_printable_name : string; fs_cb_offset_is_free : filesystem -> Int63.t -> bool; } -type lvm_cb = { - lvm_cb_probe : lvm_plugin_id -> device -> pv; - lvm_cb_list_lvs : device list -> lv list; +and lvm_probe = device -> pv + +and lvm_callbacks = { + lvm_cb_name : string; + lvm_cb_list_lvs : pv list -> lv list; lvm_cb_offset_is_free : pv -> Int63.t -> bool; } +val name_of_filesystem : filesystem -> string + +(** {3 Plug-in registration} *) + +val register_plugin : + ?partitioner:partitioner_probe -> + ?filesystem:filesystem_probe -> + ?lvm:lvm_probe -> + string -> unit + +(** {3 Plug-in-specific data management. *) + + + + + (** {2 Internal functions used by the plug-ins} *) val canonical_uuid : string -> string @@ -174,3 +197,22 @@ 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. *) + +(** {2 Functions} *) + +val open_machine : string -> (string * string) list -> machine +val close_machine : machine -> unit +val scan_machine : machine -> machine + +type ownership + +val create_ownership : machine -> ownership + +type owner = + [ `Filesystem of filesystem + | `Partitions of partitions + | `PhysicalVolume of pv ] + +val get_owners_lookup : machine -> ownership -> block_device -> + (Int63.t -> (owner * Int63.t) list) +val offset_is_free : (owner * Int63.t) list -> bool diff --git a/lib/diskimage_linux_swap.ml b/lib/diskimage_linux_swap.ml index 4933980..a3c1b23 100644 --- a/lib/diskimage_linux_swap.ml +++ b/lib/diskimage_linux_swap.ml @@ -20,14 +20,14 @@ Support for Linux swap partitions. *) -open Diskimage_utils +open Diskimage_impl open Int63.Operators -let plugin_id = "linux_swap" +let id = "linux_swap" let blocksize = ~^4096 (* XXX *) -let probe dev = +let rec probe dev = (* Load the "superblock" (ie. first 0x1000 bytes). *) let bits = dev#read_bitstring ~^0 ~^0x1000 in @@ -40,7 +40,7 @@ let probe dev = let fs_dev = new blocksize_overlay blocksize dev in { - fs_plugin_id = plugin_id; + fs_cb = callbacks; fs_dev = fs_dev; fs_blocksize = blocksize; @@ -63,9 +63,13 @@ let probe dev = (* Linux swap space is always 'free', apart from the superblock. * Compare diskimage_linux_swsuspend.ml *) -let offset_is_free _ offset = offset >= blocksize +and offset_is_free _ offset = offset >= blocksize -let callbacks = { - fs_cb_probe = probe; +and callbacks = { + fs_cb_name = id; + fs_cb_printable_name = "Linux swap"; fs_cb_offset_is_free = offset_is_free; } + +(* Register the plugin. *) +let () = register_plugin ~filesystem:probe id diff --git a/lib/diskimage_linux_swap.mli b/lib/diskimage_linux_swap.mli index a5b8426..52995b3 100644 --- a/lib/diskimage_linux_swap.mli +++ b/lib/diskimage_linux_swap.mli @@ -19,5 +19,4 @@ (**/**) -val plugin_id : string -val callbacks : Diskimage_utils.fs_cb +val id : string diff --git a/lib/diskimage_linux_swsuspend.ml b/lib/diskimage_linux_swsuspend.ml index c1eeac8..4fec7b3 100644 --- a/lib/diskimage_linux_swsuspend.ml +++ b/lib/diskimage_linux_swsuspend.ml @@ -20,14 +20,14 @@ Support for Linux software suspend partitions. *) -open Diskimage_utils +open Diskimage_impl open Int63.Operators -let plugin_id = "linux_swsuspend" +let id = "linux_swsuspend" let blocksize = ~^4096 (* XXX *) -let probe dev = +let rec probe dev = (* Load the "superblock" (ie. first 0x1000 bytes). *) let bits = dev#read_bitstring ~^0 ~^0x1000 in @@ -40,7 +40,7 @@ let probe dev = let fs_dev = new blocksize_overlay blocksize dev in { - fs_plugin_id = plugin_id; + fs_cb = callbacks; fs_dev = fs_dev; fs_blocksize = blocksize; @@ -63,9 +63,13 @@ let probe dev = (* Linux software suspend image is never free. * Compare diskimage_linux_swap.ml *) -let offset_is_free _ _ = false +and offset_is_free _ _ = false -let callbacks = { - fs_cb_probe = probe; +and callbacks = { + fs_cb_name = id; + fs_cb_printable_name = "Linux s/w suspend"; fs_cb_offset_is_free = offset_is_free; } + +(* Register the plugin. *) +let () = register_plugin ~filesystem:probe id diff --git a/lib/diskimage_linux_swsuspend.mli b/lib/diskimage_linux_swsuspend.mli index a5b8426..52995b3 100644 --- a/lib/diskimage_linux_swsuspend.mli +++ b/lib/diskimage_linux_swsuspend.mli @@ -19,5 +19,4 @@ (**/**) -val plugin_id : string -val callbacks : Diskimage_utils.fs_cb +val id : string diff --git a/lib/diskimage_lvm2.ml b/lib/diskimage_lvm2.ml index 632e879..2c2fa60 100644 --- a/lib/diskimage_lvm2.ml +++ b/lib/diskimage_lvm2.ml @@ -23,12 +23,12 @@ open Printf open ExtList -open Diskimage_utils +open Diskimage_impl open Diskimage_lvm2_metadata open Int63.Operators -let plugin_id = "LVM2" +let id = "LVM2" let sector_size_int = 512 let sector_size = ~^sector_size_int @@ -102,12 +102,12 @@ end (*----------------------------------------------------------------------*) (* Probe to see if it's an LVM2 PV. *) -let rec probe lvm_plugin_id dev = +let rec probe dev = try let uuid, _ = read_pv_label dev in if !debug then eprintf "LVM2 detected PV UUID %s\n%!" uuid; - { lvm_plugin_id = lvm_plugin_id; pv_uuid = uuid; pv_dev = dev } + { pv_cb = callbacks; pv_uuid = uuid; pv_dev = dev } with exn -> if !debug then prerr_endline (Printexc.to_string exn); raise Not_found @@ -181,15 +181,17 @@ and read_metadata dev offset len = * (as devices) and return them. Note that we don't try to detect * what is on these LVs - that will be done in the main code. *) -let rec list_lvs devs = +and list_lvs pvs = (* Read the UUID and metadata (again) from each device to end up with * an assoc list of PVs, keyed on the UUID. + * + * XXX We've already read this - we should save it in the pv struct. *) let pvs = List.map ( - fun dev -> + fun { pv_dev = dev } -> let uuid, metadata = read_pv_label dev in (uuid, (metadata, dev)) - ) devs in + ) pvs in (* Parse the metadata using the external lexer/parser. *) let pvs = List.map ( @@ -452,10 +454,13 @@ let rec list_lvs devs = * structure to determine quickly which blocks are used. Need * to store the parsed metadata in the structure ... *) -let offset_is_free _ _ = false +and offset_is_free _ _ = false -let callbacks = { - lvm_cb_probe = probe; +and callbacks = { + lvm_cb_name = id; lvm_cb_list_lvs = list_lvs; lvm_cb_offset_is_free = offset_is_free; } + +(* Register the plugin. *) +let () = register_plugin ~lvm:probe id diff --git a/lib/diskimage_lvm2.mli b/lib/diskimage_lvm2.mli index 1031b96..52995b3 100644 --- a/lib/diskimage_lvm2.mli +++ b/lib/diskimage_lvm2.mli @@ -19,5 +19,4 @@ (**/**) -val plugin_id : string -val callbacks : Diskimage_utils.lvm_cb +val id : string diff --git a/lib/diskimage_lvm2_lexer.mll b/lib/diskimage_lvm2_lexer.mll index 21136dc..cce3400 100644 --- a/lib/diskimage_lvm2_lexer.mll +++ b/lib/diskimage_lvm2_lexer.mll @@ -26,8 +26,8 @@ open Printf open Lexing + open Diskimage_impl open Diskimage_lvm2_parser - open Diskimage_utils (* Temporary buffer used for parsing strings, etc. *) let tmp = Buffer.create 80 diff --git a/lib/diskimage_mbr.ml b/lib/diskimage_mbr.ml index 009ef72..0de443b 100644 --- a/lib/diskimage_mbr.ml +++ b/lib/diskimage_mbr.ml @@ -24,11 +24,11 @@ open Printf open Unix open ExtList -open Diskimage_utils +open Diskimage_impl open Int63.Operators -let plugin_id = "mbr" +let id = "mbr" let sector_size = ~^512 @@ -91,7 +91,7 @@ let rec probe dev = let extendeds = List.concat extendeds in primaries @ extendeds *) - { parts_plugin_id = plugin_id; parts_dev = dev; parts = primaries } + { parts_cb = callbacks; parts_dev = dev; parts = primaries } | { _ } -> raise Not_found (* not an MBR *) @@ -188,9 +188,12 @@ and uint64_of_int32 u32 = (* XXX We don't currently keep enough data in the parts structure * to allow us to reconstruct missing partition table entries. *) -let offset_is_free _ _ = false +and offset_is_free _ _ = false -let callbacks = { - parts_cb_probe = probe; +and callbacks = { + parts_cb_name = id; parts_cb_offset_is_free = offset_is_free; } + +(* Register the plugin. *) +let () = register_plugin ~partitioner:probe id diff --git a/lib/diskimage_mbr.mli b/lib/diskimage_mbr.mli index d64d3b7..52995b3 100644 --- a/lib/diskimage_mbr.mli +++ b/lib/diskimage_mbr.mli @@ -19,5 +19,4 @@ (**/**) -val plugin_id : string -val callbacks : Diskimage_utils.parts_cb +val id : string diff --git a/lib/diskimage_utils.ml b/lib/diskimage_utils.ml deleted file mode 100644 index dc67e36..0000000 --- a/lib/diskimage_utils.ml +++ /dev/null @@ -1,297 +0,0 @@ -(* 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 - -open Int63.Operators - -let debug = ref false - -class virtual device = -object (self) - method virtual size : int63 - method virtual name : string - method virtual blocksize : int63 - method virtual map_block : int63 -> (device * int63) list - method virtual contiguous : Int63.t -> Int63.t - - (* Block-based read. Inefficient so normally overridden in subclasses. *) - method read offset len = - if offset < ~^0 || len < ~^0 then - invalid_arg "device: read: negative offset or length"; - - let blocksize = self#blocksize in - - (* Break the request into blocks. - * Find the first and last blocks of this request. - *) - let first_blk = offset /^ blocksize in - let offset_in_first_blk = offset -^ first_blk *^ blocksize in - let last_blk = (offset +^ len -^ ~^1) /^ blocksize in - - (* Buffer for the result. *) - let buf = Buffer.create (Int63.to_int len) in - - let not_mapped_error () = invalid_arg "device: read: block not mapped" in - - (* Copy the first block (partial). *) - (match self#map_block first_blk with - | [] -> not_mapped_error () - | (dev, base) :: _ -> - let len = - min len (blocksize -^ offset_in_first_blk) in - let str = dev#read (base +^ offset_in_first_blk) len in - Buffer.add_string buf str - ); - - (* Copy the middle blocks. *) - let rec loop blk = - if blk < last_blk then ( - (match self#map_block blk with - | [] -> not_mapped_error () - | (dev, base) :: _ -> - let str = dev#read ~^0 self#blocksize in - Buffer.add_string buf str - ); - loop (Int63.succ blk) - ) - in - loop (Int63.succ first_blk); - - (* Copy the last block (partial). *) - if first_blk < last_blk then ( - match self#map_block last_blk with - | [] -> not_mapped_error () - | (dev, base) :: _ -> - let len = (offset +^ len) -^ last_blk *^ blocksize in - let str = dev#read ~^0 len in - Buffer.add_string buf str - ); - - assert (Int63.to_int len = Buffer.length buf); - Buffer.contents buf - - (* 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, String.length str lsl 3) -end - -(* A concrete device which just direct-maps a file or /dev device. *) -class block_device filename blocksize = - let fd = openfile filename [ O_RDONLY ] 0 in - let size = Int63.of_int64 (LargeFile.fstat fd).LargeFile.st_size in -object (self) - inherit device - method read offset len = - let offset = Int63.to_int64 offset in - let len = Int63.to_int len in - ignore (LargeFile.lseek fd offset SEEK_SET); - let str = String.make len '\000' in - ignore (read fd str 0 len); - str - method size = size - method name = filename - method blocksize = blocksize - method map_block _ = [] - method contiguous offset = - size -^ offset - method close () = close fd -end - -(* A linear offset/size from an underlying device. *) -class offset_device name start size blocksize (dev : device) = -object - inherit device - method name = name - method size = size - method read offset len = - if offset < ~^0 || len < ~^0 || offset +^ len > size then - invalid_arg ( - sprintf "%s: tried to read outside device boundaries (%s/%s/%s)" - name (Int63.to_string offset) (Int63.to_string len) - (Int63.to_string size) - ); - dev#read (start+^offset) len - method blocksize = blocksize - method map_block i = [dev, i *^ blocksize +^ start] - method contiguous offset = - size -^ offset -end - -(* A device with just a modified block size. *) -class blocksize_overlay new_blocksize (dev : device) = -object - inherit device - method name = dev#name - method size = dev#size - method read = dev#read - method blocksize = new_blocksize - method map_block new_blk = - let orig_blk = new_blk *^ new_blocksize /^ dev#blocksize in - dev#map_block orig_blk - method contiguous offset = dev#size -^ offset -end - -(* The null device. Any attempt to read generates an error. *) -let null_device : device = -object - inherit device - method read _ _ = assert false - method size = ~^0 - method name = "null" - method blocksize = ~^1 - method map_block _ = assert false - method contiguous _ = ~^0 -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 : block_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_plugin_id : parts_plugin_id; (* Partitioning scheme. *) - parts_dev : device; (* Partitions (whole) device. *) - 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_plugin_id : fs_plugin_id; (* Filesystem. *) - fs_dev : device; (* Device containing the filesystem. *) - fs_blocksize : int63; (* Block size (bytes). *) - fs_blocks_total : int63; (* Total blocks. *) - fs_is_swap : bool; (* If swap, following not valid. *) - fs_blocks_reserved : int63; (* Blocks reserved for super-user. *) - fs_blocks_avail : int63; (* Blocks free (available). *) - fs_blocks_used : int63; (* Blocks in use. *) - fs_inodes_total : int63; (* Total inodes. *) - fs_inodes_reserved : int63; (* Inodes reserved for super-user. *) - fs_inodes_avail : int63; (* Inodes free (available). *) - fs_inodes_used : int63; (* Inodes in use. *) -} - -(* Physical volumes. *) -and pv = { - lvm_plugin_id : lvm_plugin_id; (* The LVM plug-in. *) - pv_dev : device; (* Device covering whole PV. *) - pv_uuid : string; (* UUID. *) -} - -(* Logical volumes. *) -and lv = { - lv_dev : device; (* Logical volume device. *) -} - -and parts_plugin_id = string -and fs_plugin_id = string -and lvm_plugin_id = string - -type parts_cb = { - parts_cb_probe : device -> partitions; - parts_cb_offset_is_free : partitions -> Int63.t -> bool; -} - -type fs_cb = { - fs_cb_probe : device -> filesystem; - fs_cb_offset_is_free : filesystem -> Int63.t -> bool; -} - -type lvm_cb = { - lvm_cb_probe : lvm_plugin_id -> device -> pv; - lvm_cb_list_lvs : device list -> lv list; - lvm_cb_offset_is_free : pv -> Int63.t -> bool; -} - -(* 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 uniq ?(cmp = Pervasives.compare) = function - | [] -> [] - | [x] -> [x] - | x :: y :: xs when cmp x y = 0 -> - uniq (x :: xs) - | x :: y :: xs -> - x :: uniq (y :: xs) - -let sort_uniq ?cmp xs = - let xs = ExtList.List.sort ?cmp xs in - let xs = uniq ?cmp xs in - xs - -let rec range a b = - if a < b then a :: range (a+1) b - else [] diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index 4572099..b0aac84 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -330,8 +330,7 @@ OPTIONS" in printf "%-32s " name; let { - Diskimage.fs_plugin_id = fs_plugin_id; - fs_blocksize = fs_blocksize; + Diskimage.fs_blocksize = fs_blocksize; fs_blocks_total = fs_blocks_total; fs_is_swap = fs_is_swap; fs_blocks_reserved = fs_blocks_reserved; @@ -343,7 +342,7 @@ OPTIONS" in fs_inodes_used = fs_inodes_used } = fs in - let fs_name = Diskimage.name_of_filesystem fs_plugin_id in + let fs_name = Diskimage.name_of_filesystem fs in if fs_is_swap then ( (* Swap partition. *) @@ -394,8 +393,7 @@ OPTIONS" in let name = printable_name machine ?disk ?partno dev in let { - Diskimage.fs_plugin_id = fs_plugin_id; - fs_blocksize = fs_blocksize; + Diskimage.fs_blocksize = fs_blocksize; fs_blocks_total = fs_blocks_total; fs_is_swap = fs_is_swap; fs_blocks_reserved = fs_blocks_reserved; @@ -407,7 +405,7 @@ OPTIONS" in fs_inodes_used = fs_inodes_used } = fs in - let fs_name = Diskimage.name_of_filesystem fs_plugin_id in + let fs_name = Diskimage.name_of_filesystem fs in let row = if fs_is_swap then