lib/diskimage_impl.ml

   1 (* Diskimage library for reading disk images.
   2    (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  *)
  19
  20 open ExtList
  21 open Printf
  22 open Unix
  23
  24 open Int63.Operators
  25
  26 let debug = ref false
  27
  28 (* Use as the natural block size for disk images, but really we should
  29  * use the 'blockdev -getbsz' command to find the real block size.
  30  *)
  31 let disk_block_size = ~^512
  32
  33 class virtual device =
  34 object (self)
  35   method virtual size : int63
  36   method virtual name : string
  37   method virtual blocksize : int63
  38   method virtual map_block : int63 -> (device * int63) list
  39   method virtual contiguous : Int63.t -> Int63.t
  40
  41   (* Block-based read.  Inefficient so normally overridden in subclasses. *)
  42   method read offset len =
  43     if offset < ~^0 || len < ~^0 then
  44       invalid_arg "device: read: negative offset or length";
  45
  46     let blocksize = self#blocksize in
  47
  48     (* Break the request into blocks.
  49      * Find the first and last blocks of this request.
  50      *)
  51     let first_blk = offset /^ blocksize in
  52     let offset_in_first_blk = offset -^ first_blk *^ blocksize in
  53     let last_blk = (offset +^ len -^ ~^1) /^ blocksize in
  54
  55     (* Buffer for the result. *)
  56     let buf = Buffer.create (Int63.to_int len) in
  57
  58     let not_mapped_error () = invalid_arg "device: read: block not mapped" in
  59
  60     (* Copy the first block (partial). *)
  61     (match self#map_block first_blk with
  62      | [] -> not_mapped_error ()
  63      | (dev, base) :: _ ->
  64          let len =
  65            min len (blocksize -^ offset_in_first_blk) in
  66          let str = dev#read (base +^ offset_in_first_blk) len in
  67          Buffer.add_string buf str
  68     );
  69
  70     (* Copy the middle blocks. *)
  71     let rec loop blk =
  72       if blk < last_blk then (
  73         (match self#map_block blk with
  74          | [] -> not_mapped_error ()
  75          | (dev, base) :: _ ->
  76              let str = dev#read ~^0 self#blocksize in
  77              Buffer.add_string buf str
  78         );
  79         loop (Int63.succ blk)
  80       )
  81     in
  82     loop (Int63.succ first_blk);
  83
  84     (* Copy the last block (partial). *)
  85     if first_blk < last_blk then (
  86       match self#map_block last_blk with
  87       | [] -> not_mapped_error ()
  88       | (dev, base) :: _ ->
  89           let len = (offset +^ len) -^ last_blk *^ blocksize in
  90           let str = dev#read ~^0 len in
  91           Buffer.add_string buf str
  92     );
  93
  94     assert (Int63.to_int len = Buffer.length buf);
  95     Buffer.contents buf
  96
  97   (* Helper method to read a chunk of data into a bitstring. *)
  98   method read_bitstring offset len =
  99     let str = self#read offset len in
 100     (str, 0, String.length str lsl 3)
 101 end
 102
 103 (* A concrete device which just direct-maps a file or /dev device. *)
 104 class block_device filename blocksize =
 105   let fd = openfile filename [ O_RDONLY ] 0 in
 106   let size = Int63.of_int64 (LargeFile.fstat fd).LargeFile.st_size in
 107 object (self)
 108   inherit device
 109   method read offset len =
 110     let offset = Int63.to_int64 offset in
 111     let len = Int63.to_int len in
 112     ignore (LargeFile.lseek fd offset SEEK_SET);
 113     let str = String.make len '\000' in
 114     ignore (read fd str 0 len);
 115     str
 116   method size = size
 117   method name = filename
 118   method blocksize = blocksize
 119   method map_block _ = []
 120   method contiguous offset =
 121     size -^ offset
 122   method close () = close fd
 123 end
 124
 125 (* A linear offset/size from an underlying device. *)
 126 class offset_device name start size blocksize (dev : device) =
 127 object
 128   inherit device
 129   method name = name
 130   method size = size
 131   method read offset len =
 132     if offset < ~^0 || len < ~^0 || offset +^ len > size then
 133       invalid_arg (
 134         sprintf "%s: tried to read outside device boundaries (%s/%s/%s)"
 135           name (Int63.to_string offset) (Int63.to_string len)
 136           (Int63.to_string size)
 137       );
 138     dev#read (start+^offset) len
 139   method blocksize = blocksize
 140   method map_block i = [dev, i *^ blocksize +^ start]
 141   method contiguous offset =
 142     size -^ offset
 143 end
 144
 145 (* A device with just a modified block size. *)
 146 class blocksize_overlay new_blocksize (dev : device) =
 147 object
 148   inherit device
 149   method name = dev#name
 150   method size = dev#size
 151   method read = dev#read
 152   method blocksize = new_blocksize
 153   method map_block new_blk =
 154     let orig_blk = new_blk *^ new_blocksize /^ dev#blocksize in
 155     dev#map_block orig_blk
 156   method contiguous offset = dev#size -^ offset
 157 end
 158
 159 (* The null device.  Any attempt to read generates an error. *)
 160 let null_device : device =
 161 object
 162   inherit device
 163   method read _ _ = assert false
 164   method size = ~^0
 165   method name = "null"
 166   method blocksize = ~^1
 167   method map_block _ = assert false
 168   method contiguous _ = ~^0
 169 end
 170
 171 type machine = {
 172   m_name : string;                      (* Machine name. *)
 173   m_disks : disk list;                  (* Machine disks. *)
 174   m_lv_filesystems :
 175     (lv * filesystem) list;             (* Machine LV filesystems. *)
 176 }
 177 and disk = {
 178   d_name : string;                      (* Device name (eg "hda") *)
 179
 180   (* About the device itself. *)
 181   d_dev : block_device;                 (* Disk device. *)
 182   d_content : disk_content;             (* What's on it. *)
 183 }
 184 and disk_content =
 185   [ `Unknown                            (* Not probed or unknown. *)
 186   | `Partitions of partitions           (* Contains partitions. *)
 187   | `Filesystem of filesystem           (* Contains a filesystem directly. *)
 188   | `PhysicalVolume of pv               (* Contains an LVM PV. *)
 189   ]
 190
 191 (* Partitions. *)
 192
 193 and partitions = {
 194   parts_cb : partitioner_callbacks;     (* Partitioning scheme. *)
 195   parts_dev : device;                   (* Partitions (whole) device. *)
 196   parts : partition list                (* Partitions. *)
 197 }
 198 and partition = {
 199   part_status : partition_status;       (* Bootable, etc. *)
 200   part_type : int;                      (* Partition filesystem type. *)
 201   part_dev : device;                    (* Partition device. *)
 202   part_content : partition_content;     (* What's on it. *)
 203 }
 204 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
 205 and partition_content =
 206   [ `Unknown                            (* Not probed or unknown. *)
 207   | `Filesystem of filesystem           (* Filesystem. *)
 208   | `PhysicalVolume of pv               (* Contains an LVM PV. *)
 209   ]
 210
 211 (* Filesystems (also swap devices). *)
 212 and filesystem = {
 213   fs_cb : filesystem_callbacks;         (* Filesystem. *)
 214   fs_dev : device;                      (* Device containing the filesystem. *)
 215   fs_blocksize : int63;                 (* Block size (bytes). *)
 216   fs_blocks_total : int63;              (* Total blocks. *)
 217   fs_is_swap : bool;                    (* If swap, following not valid. *)
 218   fs_blocks_reserved : int63;           (* Blocks reserved for super-user. *)
 219   fs_blocks_avail : int63;              (* Blocks free (available). *)
 220   fs_blocks_used : int63;               (* Blocks in use. *)
 221   fs_inodes_total : int63;              (* Total inodes. *)
 222   fs_inodes_reserved : int63;           (* Inodes reserved for super-user. *)
 223   fs_inodes_avail : int63;              (* Inodes free (available). *)
 224   fs_inodes_used : int63;               (* Inodes in use. *)
 225 }
 226
 227 (* Physical volumes. *)
 228 and pv = {
 229   pv_cb : lvm_callbacks;                (* The LVM plug-in. *)
 230   pv_dev : device;                      (* Device covering whole PV. *)
 231   pv_uuid : string;                     (* UUID. *)
 232 }
 233
 234 (* Logical volumes. *)
 235 and lv = {
 236   lv_dev : device;                      (* Logical volume device. *)
 237 }
 238
 239 (* Tables of callbacks. *)
 240 and partitioner_probe = device -> partitions
 241
 242 and partitioner_callbacks = {
 243   parts_cb_name : string;
 244   parts_cb_offset_is_free : partitions -> Int63.t -> bool;
 245 }
 246
 247 and filesystem_probe = device -> filesystem
 248
 249 and filesystem_callbacks = {
 250   fs_cb_name : string;
 251   fs_cb_printable_name : string;
 252   fs_cb_offset_is_free : filesystem -> Int63.t -> bool;
 253 }
 254
 255 and lvm_probe = device -> pv
 256
 257 and lvm_callbacks = {
 258   lvm_cb_name : string;
 259   lvm_cb_list_lvs : pv list -> lv list;
 260   lvm_cb_offset_is_free : pv -> Int63.t -> bool;
 261 }
 262
 263 let name_of_filesystem { fs_cb = { fs_cb_printable_name = name } } = name
 264
 265 (*----------------------------------------------------------------------*)
 266 (* Helper functions. *)
 267
 268 (* Convert a UUID (containing '-' chars) to canonical form. *)
 269 let canonical_uuid uuid =
 270   let uuid' = String.make 32 ' ' in
 271   let j = ref 0 in
 272   for i = 0 to String.length uuid - 1 do
 273     if !j >= 32 then invalid_arg "canonical_uuid";
 274     let c = uuid.[i] in
 275     if c <> '-' then ( uuid'.[!j] <- c; incr j )
 276   done;
 277   if !j <> 32 then invalid_arg "canonical_uuid";
 278   uuid'
 279
 280 (* This version by Isaac Trotts. *)
 281 let group_by ?(cmp = Pervasives.compare) ls =
 282   let ls' =
 283     List.fold_left
 284       (fun acc (day1, x1) ->
 285          match acc with
 286              [] -> [day1, [x1]]
 287            | (day2, ls2) :: acctl ->
 288                if cmp day1 day2 = 0
 289                then (day1, x1 :: ls2) :: acctl
 290                else (day1, [x1]) :: acc)
 291       []
 292       ls
 293   in
 294   let ls' = List.rev ls' in
 295   List.map (fun (x, xs) -> x, List.rev xs) ls'
 296
 297 let rec uniq ?(cmp = Pervasives.compare) = function
 298   | [] -> []
 299   | [x] -> [x]
 300   | x :: y :: xs when cmp x y = 0 ->
 301       uniq (x :: xs)
 302   | x :: y :: xs ->
 303       x :: uniq (y :: xs)
 304
 305 let sort_uniq ?cmp xs =
 306   let xs = ExtList.List.sort ?cmp xs in
 307   let xs = uniq ?cmp xs in
 308   xs
 309
 310 let rec range a b =
 311   if a < b then a :: range (a+1) b
 312   else []
 313
 314 (*----------------------------------------------------------------------*)
 315 (* The plug-ins. *)
 316
 317 let partitioners = ref []
 318 let filesystems = ref []
 319 let lvms = ref []
 320
 321 let register_plugin ?partitioner ?filesystem ?lvm id =
 322   (match partitioner with
 323    | None -> ()
 324    | Some probe -> partitioners := !partitioners @ [id, probe]
 325   );
 326   (match filesystem with
 327    | None -> ()
 328    | Some probe -> filesystems := !filesystems @ [id, probe]
 329   );
 330   (match lvm with
 331    | None -> ()
 332    | Some probe -> lvms := !lvms @ [id, probe]
 333   )
 334
 335 (* Probe a device for partitions.  Returns [Some parts] or [None]. *)
 336 let probe_for_partitions dev =
 337   if !debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
 338   let rec loop = function
 339     | [] -> None
 340     | (_, probe) :: rest ->
 341         try Some (probe dev)
 342         with Not_found -> loop rest
 343   in
 344   let r = loop !partitioners in
 345   if !debug then (
 346     match r with
 347     | None -> eprintf "no partitions found on %s\n%!" dev#name
 348     | Some { parts_cb = { parts_cb_name = name }; parts = parts } ->
 349         eprintf "found %d %s partitions on %s\n"
 350           (List.length parts) name dev#name
 351   );
 352   r
 353
 354 (* Probe a device for a filesystem.  Returns [Some fs] or [None]. *)
 355 let probe_for_filesystem dev =
 356   if !debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
 357   let rec loop = function
 358     | [] -> None
 359     | (_, probe) :: rest ->
 360         try Some (probe dev)
 361         with Not_found -> loop rest
 362   in
 363   let r = loop !filesystems in
 364   if !debug then (
 365     match r with
 366     | None -> eprintf "no filesystem found on %s\n%!" dev#name
 367     | Some fs ->
 368         eprintf "found a filesystem on %s:\n" dev#name;
 369         eprintf "\t%s\n%!" fs.fs_cb.fs_cb_name
 370   );
 371   r
 372
 373 (* Probe a device for a PV.  Returns [Some pv] or [None]. *)
 374 let probe_for_pv dev =
 375   if !debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
 376   let rec loop = function
 377     | [] -> None
 378     | (_, probe) :: rest ->
 379         try Some (probe dev)
 380         with Not_found -> loop rest
 381   in
 382   let r = loop !lvms in
 383   if !debug then (
 384     match r with
 385     | None -> eprintf "no PV found on %s\n%!" dev#name
 386     | Some { pv_cb = { lvm_cb_name = name } } ->
 387         eprintf "%s contains a %s PV\n%!" dev#name name
 388   );
 389   r
 390
 391 (*----------------------------------------------------------------------*)
 392 (* Create machine description. *)
 393 let open_machine name disks =
 394   let disks = List.map (
 395     fun (name, path) ->
 396       let dev = new block_device path disk_block_size (* XXX *) in
 397       { d_name = name; d_dev = dev; d_content = `Unknown }
 398   ) disks in
 399   { m_name = name; m_disks = disks; m_lv_filesystems = [] }
 400
 401 let close_machine { m_disks = m_disks } =
 402   (* Only close the disks, assume all other devices are derived from them. *)
 403   List.iter (fun { d_dev = d_dev } -> d_dev#close ()) m_disks
 404
 405 (* Main scanning function for filesystems. *)
 406 let scan_machine ({ m_disks = m_disks } as machine) =
 407   let m_disks = List.map (
 408     fun ({ d_dev = dev } as disk) ->
 409       let dev = (dev :> device) in
 410       (* See if it is partitioned first. *)
 411       let parts = probe_for_partitions dev in
 412       match parts with
 413       | Some parts ->
 414           { disk with d_content = `Partitions parts }
 415       | None ->
 416           (* Not partitioned.  Does it contain a filesystem? *)
 417           let fs = probe_for_filesystem dev in
 418           match fs with
 419           | Some fs ->
 420               { disk with d_content = `Filesystem fs }
 421           | None ->
 422               (* Not partitioned, no filesystem, is it a PV? *)
 423               let pv = probe_for_pv dev in
 424               match pv with
 425               | Some pv ->
 426                   { disk with d_content = `PhysicalVolume pv }
 427               | None ->
 428                   disk (* Spare/unknown. *)
 429   ) m_disks in
 430
 431   (* Now we have either detected partitions or a filesystem on each
 432    * physical device (or perhaps neither).  See what is on those
 433    * partitions.
 434    *)
 435   let m_disks = List.map (
 436     function
 437     | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
 438         let ps = List.map (
 439           fun p ->
 440             if p.part_status = Bootable || p.part_status = Nonbootable then (
 441               let fs = probe_for_filesystem p.part_dev in
 442               match fs with
 443               | Some fs ->
 444                   { p with part_content = `Filesystem fs }
 445               | None ->
 446                   (* Is it a PV? *)
 447                   let pv = probe_for_pv p.part_dev in
 448                   match pv with
 449                   | Some lvm_name ->
 450                       { p with part_content = `PhysicalVolume lvm_name }
 451                   | None ->
 452                       p (* Spare/unknown. *)
 453             ) else p
 454         ) parts.parts in
 455         let parts = { parts with parts = ps } in
 456         { disk with d_content = `Partitions parts }
 457     | disk -> disk
 458   ) m_disks in
 459
 460   (* LVM filesystem detection
 461    *
 462    * Look for all disks/partitions which have been identified as PVs
 463    * and pass those back to the respective LVM plugin for LV detection.
 464    *
 465    * (Note - a two-stage process because an LV can be spread over
 466    * several PVs, so we have to detect all PVs belonging to a
 467    * domain first).
 468    *
 469    * XXX To deal with RAID (ie. md devices) we will need to loop
 470    * around here because RAID is like LVM except that they normally
 471    * present as block devices which can be used by LVM.
 472    *)
 473   (* First: LV detection.
 474    * Find all physical volumes, can be disks or partitions.
 475    *)
 476   let pvs_on_disks = List.filter_map (
 477     function
 478     | { d_content = `PhysicalVolume pv } -> Some pv
 479     | _ -> None
 480   ) m_disks in
 481   let pvs_on_partitions = List.map (
 482     function
 483     | { d_content = `Partitions { parts = parts } } ->
 484         List.filter_map (
 485           function
 486           | { part_content = `PhysicalVolume pv } -> Some pv
 487           | _ -> None
 488         ) parts
 489     | _ -> []
 490   ) m_disks in
 491   let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in
 492
 493   (* Second: filesystem on LV detection.
 494    * Group the LVs by LVM plug-in ID.
 495    *)
 496   let lvs =
 497     List.map (fun ({pv_cb = {lvm_cb_name = name}} as pv) -> name, pv) lvs in
 498   let lvs = List.sort lvs in
 499   let lvs = group_by lvs in
 500
 501   let lvs = List.map (fun (name, pvs) ->
 502                         let pv = List.hd pvs in
 503                         pv.pv_cb.lvm_cb_list_lvs pvs) lvs in
 504   let lvs = List.concat lvs in
 505
 506   (* lvs is a list of potential LV devices.  Now run them through the
 507    * probes to see if any contain filesystems.
 508    *)
 509   let filesystems =
 510     List.filter_map (
 511       fun ({ lv_dev = dev } as lv) ->
 512         match probe_for_filesystem dev with
 513         | Some fs -> Some (lv, fs)
 514         | None -> None
 515     ) lvs in
 516
 517   { machine with
 518       m_disks = m_disks;
 519       m_lv_filesystems = filesystems }
 520
 521 (*----------------------------------------------------------------------*)
 522
 523 (* We describe the ownership of each part of the disk using a
 524  * segment tree. http://en.wikipedia.org/wiki/Segment_tree
 525  *
 526  * Note that each part can (and usually is) owned multiple times
 527  * (eg. by a filesystem and by the partition that the filesystem
 528  * lies inside).  Also, the segment tree is effectively read-only.
 529  * We build it up as a final step given the flat list of segments
 530  * identified by the algorithm in 'iter_over_machine'.
 531  *)
 532
 533 (* General binary tree type.  Data 'a is stored in the leaves and 'b
 534  * is stored in the nodes.
 535  *)
 536 type ('a,'b) binary_tree =
 537   | Leaf of 'a
 538   | Node of ('a,'b) binary_tree * 'b * ('a,'b) binary_tree
 539
 540 (* This prints out the binary tree in graphviz dot format. *)
 541 let print_binary_tree leaf_printer node_printer tree =
 542   (* Assign a unique, fixed label to each node. *)
 543   let label =
 544     let i = ref 0 in
 545     let hash = Hashtbl.create 13 in
 546     fun node ->
 547       try Hashtbl.find hash node
 548       with Not_found ->
 549         let i = incr i; !i in
 550         let label = "n" ^ string_of_int i in
 551         Hashtbl.add hash node label;
 552         label
 553   in
 554   (* Recursively generate the graphviz file. *)
 555   let rec print = function
 556     | (Leaf a as leaf) ->
 557         eprintf "  %s [shape=box, label=\"%s\"];\n"
 558           (label leaf) (leaf_printer a)
 559     | (Node (left,b,right) as node) ->
 560         eprintf "  %s [label=\"%s\"];\n"
 561           (label node) (node_printer b);
 562         eprintf "  %s -> %s [tailport=sw];\n" (label node) (label left);
 563         eprintf "  %s -> %s [tailport=se];\n" (label node) (label right);
 564         print left;
 565         print right;
 566   in
 567   eprintf "/* Use 'dot -Tpng foo.dot > foo.png' to convert to a png file. */\n";
 568   eprintf "digraph G {\n";
 569   print tree;
 570   eprintf "}\n%!";
 571
 572 type owner =
 573     [ `Filesystem of filesystem
 574     | `Partitions of partitions
 575     | `PhysicalVolume of pv ]
 576
 577 (* A segment describes the owner of a range of disk addresses. *)
 578 type segment = owner * int63            (* owner, owner offset *)
 579
 580 type interval = int63 * int63           (* start point, end point (bytes) *)
 581
 582 (* The special segment tree structure that we construct in create_ownership. *)
 583 type segment_tree =
 584     (interval * segment list, interval * segment list) binary_tree
 585
 586 type ownership =
 587     (device *                           (* block_device (disk) *)
 588        segment_tree) list               (* segment tree for this disk *)
 589
 590 (* List of owned segments before we build the segment tree. *)
 591 type ownership_list =
 592     (device *                           (* block_device (disk) *)
 593        (int63 * int63 *                 (* disk offset, size of segment *)
 594           owner * int63                 (* owner, owner offset *)
 595        )
 596     ) list
 597
 598 (* Ownership tables. *)
 599 let create_ownership machine =
 600   (* Iterate over all the things which can claim ownership of a
 601    * disk block (filesystems, partitions, PVs).
 602    *)
 603   let rec iter_over_machine
 604       ({m_disks = disks; m_lv_filesystems = lv_filesystems} as machine) =
 605
 606     (* No segments to begin with. *)
 607     let ownership = [] in
 608
 609     (* Iterate over disks. *)
 610     let ownership =
 611       List.fold_left (
 612         fun ownership ->
 613           function
 614           | { d_content = (`Filesystem fs as owner) } ->
 615               iter_over_filesystem machine ownership fs owner
 616           | { d_content = (`Partitions parts as owner) } ->
 617               iter_over_partitions machine ownership parts owner
 618           | { d_content = (`PhysicalVolume pv as owner) } ->
 619               iter_over_pv machine ownership pv owner
 620           | { d_content = `Unknown } -> ownership
 621       ) ownership disks in
 622
 623     (* Iterate over LV filesystems. *)
 624     let ownership =
 625       List.fold_left (
 626         fun ownership (lv, fs) ->
 627           let owner = `Filesystem fs in
 628           iter_over_filesystem machine ownership fs owner
 629       ) ownership lv_filesystems in
 630
 631     ownership
 632
 633   (* Iterate over the blocks in a single filesystem. *)
 634   and iter_over_filesystem machine ownership {fs_dev = dev} owner =
 635     iter_over_device machine ownership dev owner
 636
 637   (* Iterate over the blocks in a set of partitions, then
 638    * iterate over the contents of the partitions.
 639    *)
 640   and iter_over_partitions machine ownership
 641       {parts = parts; parts_dev = parts_dev} owner =
 642     let ownership = iter_over_device machine ownership parts_dev owner in
 643
 644     let ownership =
 645       List.fold_left (
 646         fun ownership ->
 647           function
 648           | { part_content = (`Filesystem fs as owner) } ->
 649               iter_over_filesystem machine ownership fs owner
 650           | { part_content = (`PhysicalVolume pv as owner) } ->
 651               iter_over_pv machine ownership pv owner
 652           | { part_content = `Unknown } -> ownership
 653       ) ownership parts in
 654
 655     ownership
 656
 657   (* Iterate over the blocks in a PV. *)
 658   and iter_over_pv machine ownership {pv_dev = dev} owner =
 659     iter_over_device machine ownership dev owner
 660
 661   (* Iterate over the blocks in a device, assigning ownership to 'owner'
 662    *
 663    * In reality (1): There can be several owners for each block, so we
 664    * incrementally add ownership to the ownership_list (which eventually
 665    * will be turned into a segment tree).
 666    * In reality (2): Iterating over blocks would take ages and result
 667    * in a very inefficient ownership representation.  Instead we look
 668    * at minimum contiguous extents.
 669    *)
 670   and iter_over_device { m_disks = disks } ownership dev owner =
 671     let size = dev#size in
 672     let disks = List.map (fun {d_dev = dev} -> (dev :> device)) disks in
 673
 674     let rec loop ownership offset =
 675       if offset < size then (
 676         let devs, extent = get_next_extent disks dev offset in
 677         if devs = [] then
 678           eprintf "warning: no device found under %s\n"
 679             (string_of_owner owner);
 680         let ownership =
 681           List.fold_left (
 682             fun ownership (disk, disk_offset) ->
 683               let elem = disk, (disk_offset, extent, owner, offset) in
 684               elem :: ownership
 685           ) ownership devs in
 686         loop ownership (offset +^ extent)
 687       )
 688       else ownership
 689     in
 690     loop ownership ~^0
 691
 692   (* Return the length of the next contiguous region in the device starting
 693    * at the given byte offset.  Also return the underlying block device(s)
 694    * if there is one.
 695    *)
 696   and get_next_extent disks (dev : device) offset =
 697     let this_extent = dev#contiguous offset in
 698
 699     (* If this disk is a block_device (a member of the 'disks' list)
 700      * then we've hit the bottom layer of devices, so just return it.
 701      *)
 702     if List.memq dev disks then
 703       [dev, offset], this_extent
 704     else (
 705       let blocksize = dev#blocksize in
 706       let block = offset /^ blocksize in
 707       let offset_in_block = offset -^ block *^ blocksize in
 708
 709       (* Map from this block to the devices one layer down. *)
 710       let devs = dev#map_block block in
 711
 712       (* Get the real device offsets, adding the offset from start of block. *)
 713       let devs =
 714         List.map
 715           (fun (dev, dev_offset) -> dev, dev_offset +^ offset_in_block)
 716           devs in
 717
 718       let devs =
 719         List.map
 720           (fun (dev, dev_offset) ->
 721              get_next_extent disks dev dev_offset)
 722           devs in
 723
 724       (* Work out the minimum contiguous extent from this offset. *)
 725       let devs, extent =
 726         let extents = List.map snd devs in
 727         let devs = List.concat (List.map fst devs) in
 728         let extent = List.fold_left min this_extent extents in
 729         devs, extent in
 730
 731       devs, extent
 732     )
 733
 734   and string_of_owner = function
 735     | `Filesystem {fs_cb = {fs_cb_name = name}; fs_dev = fs_dev} ->
 736         sprintf "%s(%s)" fs_dev#name name
 737     | `PhysicalVolume { pv_uuid = pv_uuid } ->
 738         "PV:" ^ pv_uuid
 739     | `Partitions { parts_cb = {parts_cb_name = name} } ->
 740         name
 741   in
 742
 743   (* Build the list of segments. *)
 744   let ownership : ownership_list = iter_over_machine machine in
 745
 746   (* Group the segments together by disk. *)
 747   let ownership =
 748     let ownership = List.sort ownership in
 749     group_by ownership in
 750
 751   (* If debugging, print the segments that we found. *)
 752   if !debug then (
 753     List.iter (
 754       fun (disk, segments) ->
 755         eprintf "ownership segment list of %s %s:\n" machine.m_name disk#name;
 756         List.iter (
 757           fun (disk_offset, size, owner, owner_offset) ->
 758             let blocksize = disk#blocksize in
 759             let disk_offset_in_blocks, disk_offset_in_block =
 760               disk_offset /^ blocksize, disk_offset %^ blocksize in
 761             let size_in_blocks, size_in_block =
 762               size /^ blocksize, size %^ blocksize in
 763
 764             eprintf "  %s[%s:%s] %s[%s:%s] %s@%s\n"
 765               (Int63.to_string disk_offset)
 766                 (Int63.to_string disk_offset_in_blocks)
 767                 (Int63.to_string disk_offset_in_block)
 768               (Int63.to_string size)
 769                 (Int63.to_string size_in_blocks)
 770                 (Int63.to_string size_in_block)
 771               (string_of_owner owner)
 772               (Int63.to_string owner_offset)
 773         ) segments
 774     ) ownership
 775   );
 776
 777   (* Build the segment tree from the ownership list (of segments).
 778    * For an explanation of this process see:
 779    * http://en.wikipedia.org/wiki/Segment_tree
 780    *)
 781   let ownership =
 782     List.map (
 783       fun (disk, segments) ->
 784         (* Construct the list of distinct endpoints. *)
 785         let eps =
 786           List.map
 787             (fun (start, size, _, _) -> [start; start +^ size])
 788             segments in
 789         let eps = sort_uniq (List.concat eps) in
 790
 791         (* Construct the elementary intervals. *)
 792         let elints =
 793           let elints, lastpoint =
 794             List.fold_left (
 795               fun (elints, prevpoint) point ->
 796                 ((point, point) :: (prevpoint, point) :: elints), point
 797             ) ([], Int63.min_int) eps in
 798           let elints = (lastpoint, Int63.max_int) :: elints in
 799           List.rev elints in
 800
 801         if !debug then (
 802           eprintf "elementary intervals for %s (%d in total):\n"
 803             disk#name (List.length elints);
 804           List.iter (
 805             fun (startpoint, endpoint) ->
 806               eprintf "  %s %s\n"
 807                 (Int63.to_string startpoint) (Int63.to_string endpoint)
 808           ) elints
 809         );
 810
 811         (* Construct the binary tree of elementary intervals. *)
 812         let tree =
 813           (* Each elementary interval becomes a leaf. *)
 814           let elints = List.map (fun elint -> Leaf elint) elints in
 815           (* Recursively build this into a binary tree. *)
 816           let rec make_layer = function
 817             | [] -> []
 818             | ([_] as x) -> x
 819             (* Turn pairs of leaves at the bottom level into nodes. *)
 820             | (Leaf _ as a) :: (Leaf _ as b) :: xs ->
 821                 let xs = make_layer xs in
 822                 Node (a, (), b) :: xs
 823             (* Turn pairs of nodes at higher levels into nodes. *)
 824             | (Node _ as left) :: ((Node _|Leaf _) as right) :: xs ->
 825                 let xs = make_layer xs in
 826                 Node (left, (), right) :: xs
 827             | Leaf _ :: _ -> assert false (* never happens??? (I think) *)
 828           in
 829           let rec loop = function
 830             | [] -> assert false
 831             | [x] -> x
 832             | xs -> loop (make_layer xs)
 833           in
 834           loop elints in
 835
 836         if !debug then (
 837           let leaf_printer (startpoint, endpoint) =
 838             sprintf "%s-%s"
 839               (Int63.to_string startpoint) (Int63.to_string endpoint)
 840           in
 841           let node_printer () = "" in
 842           print_binary_tree leaf_printer node_printer tree
 843         );
 844
 845         (* Insert the segments into the tree one by one. *)
 846         let tree =
 847           (* For each node/leaf in the tree, add its interval and an
 848            * empty list which will be used to store the segments.
 849            *)
 850           let rec interval_tree = function
 851             | Leaf elint -> Leaf (elint, [])
 852             | Node (left, (), right) ->
 853                 let left = interval_tree left in
 854                 let right = interval_tree right in
 855                 let (leftstart, _) = interval_of_node left in
 856                 let (_, rightend) = interval_of_node right in
 857                 let interval = leftstart, rightend in
 858                 Node (left, (interval, []), right)
 859           and interval_of_node = function
 860             | Leaf (elint, _) -> elint
 861             | Node (_, (interval, _), _) -> interval
 862           in
 863
 864           let tree = interval_tree tree in
 865           (* This should always be true: *)
 866           assert (interval_of_node tree = (Int63.min_int, Int63.max_int));
 867
 868           (* "Contained in" operator.
 869            * 'a <-< b' iff 'a' is a subinterval of 'b'.
 870            *      |<---- a ---->|
 871            * |<----------- b ----------->|
 872            *)
 873           let (<-<) (a1, a2) (b1, b2) = b1 <= a1 && a2 <= b2 in
 874
 875           (* "Intersects" operator.
 876            * 'a /\ b' iff intervals 'a' and 'b' overlap, eg:
 877            *      |<---- a ---->|
 878            *                |<----------- b ----------->|
 879            *)
 880           let ( /\ ) (a1, a2) (b1, b2) = a2 > b1 || b2 > a1 in
 881
 882           let rec insert_segment tree segment =
 883             let start, size, owner, owner_offset = segment in
 884             let seginterval = start, start +^ size in
 885             let seg = owner, owner_offset in
 886
 887             match tree with
 888             (* Test if we should insert into this leaf or node: *)
 889             | Leaf (interval, segs) when interval <-< seginterval ->
 890                 Leaf (interval, seg :: segs)
 891             | Node (left, (interval, segs), right)
 892                 when interval <-< seginterval ->
 893                 Node (left, (interval, seg :: segs), right)
 894
 895             | (Leaf _) as leaf -> leaf
 896
 897             (* Else, should we insert into left or right subtrees? *)
 898             | Node (left, i, right) ->
 899                 let left =
 900                   if seginterval /\ interval_of_node left then
 901                     insert_segment left segment
 902                   else
 903                     left in
 904                 let right =
 905                   if seginterval /\ interval_of_node right then
 906                     insert_segment right segment
 907                   else
 908                     right in
 909                 Node (left, i, right)
 910           in
 911           let tree = List.fold_left insert_segment tree segments in
 912           tree in
 913
 914         if !debug then (
 915           let printer ((sp, ep), segments) =
 916             sprintf "[%s-%s] " (Int63.to_string sp) (Int63.to_string ep) ^
 917               String.concat ";"
 918               (List.map (fun (owner,_) -> string_of_owner owner)
 919                  segments)
 920           in
 921           print_binary_tree printer printer tree
 922         );
 923         (disk, tree)
 924     ) ownership in
 925
 926   (* Return the ownership structure. *)
 927   ownership
 928
 929 let get_owners_lookup machine ownership (disk : block_device) =
 930   (* Get the correct tree. *)
 931   let tree = List.assoc (disk :> device) ownership in
 932
 933   fun offset ->
 934     (* Warning: This 'hot' code was carefully optimized based on
 935      * feedback from 'gprof'.  Avoid fiddling with it.
 936      *)
 937     let rec query = function
 938       | Leaf (_, segments) -> segments
 939
 940       (* Try to avoid expensive '@' operator if node segments is empty: *)
 941       | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
 942               (_, []),
 943               right) ->
 944           let subsegments =
 945             if offset < leftend then query left else query right in
 946           subsegments
 947
 948       (* ... or a singleton: *)
 949       | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
 950               (_, [segment]),
 951               right) ->
 952           let subsegments =
 953             if offset < leftend then query left else query right in
 954           segment :: subsegments
 955
 956       (* Normal recursive case: *)
 957       | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
 958               (_, segments),
 959               right) ->
 960           let subsegments =
 961             if offset < leftend then query left else query right in
 962           segments @ subsegments
 963     in
 964     let owners = query tree in
 965
 966     List.map (
 967       fun (owner, owner_offset) -> (owner, offset -^ owner_offset)
 968     ) owners
 969
 970 (* Find out if a disk offset is free.
 971  * Current algorithm just checks that at least one owner says
 972  * it is free.  We could be smarter about this.
 973  *)
 974 let offset_is_free owners =
 975   List.exists (
 976     function
 977     | `Filesystem fs, offset ->
 978         fs.fs_cb.fs_cb_offset_is_free fs offset
 979     | `Partitions parts, offset ->
 980         parts.parts_cb.parts_cb_offset_is_free parts offset
 981     | `PhysicalVolume pv, offset ->
 982         pv.pv_cb.lvm_cb_offset_is_free pv offset
 983   ) owners