Removed warning about unused return value.
[virt-df.git] / lib / diskimage.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 Printf
21 open ExtList
22 open Unix
23
24 open Int63.Operators
25
26 include Diskimage_utils
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 (*----------------------------------------------------------------------*)
34 (* The plug-ins. *)
35 let partition_types = [
36   Diskimage_mbr.plugin_id,
37     ("MBR", Diskimage_mbr.probe);
38 ]
39
40 let filesystem_types = [
41   Diskimage_ext2.plugin_id,
42     ("Linux ext2/3", Diskimage_ext2.probe);
43   Diskimage_linux_swap.plugin_id,
44     ("Linux swap", Diskimage_linux_swap.probe);
45   Diskimage_linux_swsuspend.plugin_id,
46     ("Linux s/w suspend", Diskimage_linux_swsuspend.probe);
47 ]
48
49 let lvm_types = [
50   Diskimage_lvm2.plugin_id,
51     ("Linux LVM2", Diskimage_lvm2.probe, Diskimage_lvm2.list);
52 ]
53
54 let name_of_parts id =
55   let name, _ = List.assoc id partition_types in
56   name
57 let name_of_filesystem id =
58   let name, _ = List.assoc id filesystem_types in
59   name
60 let name_of_lvm id =
61   let name, _, _ = List.assoc id lvm_types in
62   name
63
64 (* Probe a device for partitions.  Returns [Some parts] or [None]. *)
65 let probe_for_partitions dev =
66   if !debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
67   let rec loop = function
68     | [] -> None
69     | (parts_plugin_id, (_, probe_fn)) :: rest ->
70         try Some (probe_fn dev)
71         with Not_found -> loop rest
72   in
73   let r = loop partition_types in
74   if !debug then (
75     match r with
76     | None -> eprintf "no partitions found on %s\n%!" dev#name
77     | Some { parts_plugin_id = name; parts = parts } ->
78         eprintf "found %d %s partitions on %s\n"
79           (List.length parts) name dev#name
80   );
81   r
82
83 (* Probe a device for a filesystem.  Returns [Some fs] or [None]. *)
84 let probe_for_filesystem dev =
85   if !debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
86   let rec loop = function
87     | [] -> None
88     | (fs_name, (_, probe_fn)) :: rest ->
89         try Some (probe_fn dev)
90         with Not_found -> loop rest
91   in
92   let r = loop filesystem_types in
93   if !debug then (
94     match r with
95     | None -> eprintf "no filesystem found on %s\n%!" dev#name
96     | Some fs ->
97         eprintf "found a filesystem on %s:\n" dev#name;
98         eprintf "\t%s\n%!" fs.fs_plugin_id
99   );
100   r
101
102 (* Probe a device for a PV.  Returns [Some lvm_name] or [None]. *)
103 let probe_for_pv dev =
104   if !debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
105   let rec loop = function
106     | [] -> None
107     | (lvm_name, (_, probe_fn, _)) :: rest ->
108         try Some (probe_fn lvm_name dev)
109         with Not_found -> loop rest
110   in
111   let r = loop lvm_types in
112   if !debug then (
113     match r with
114     | None -> eprintf "no PV found on %s\n%!" dev#name
115     | Some { lvm_plugin_id = name } ->
116         eprintf "%s contains a %s PV\n%!" dev#name name
117   );
118   r
119
120 let list_lvs lvm_name devs =
121   let _, _, list_lvs_fn = List.assoc lvm_name lvm_types in
122   list_lvs_fn devs
123
124 (*----------------------------------------------------------------------*)
125 (* Create machine description. *)
126 let open_machine name disks =
127   let disks = List.map (
128     fun (name, path) ->
129       let dev = new block_device path disk_block_size (* XXX *) in
130       { d_name = name; d_dev = dev; d_content = `Unknown }
131   ) disks in
132   { m_name = name; m_disks = disks; m_lv_filesystems = [] }
133
134 let close_machine { m_disks = m_disks } =
135   (* Only close the disks, assume all other devices are derived from them. *)
136   List.iter (fun { d_dev = d_dev } -> d_dev#close ()) m_disks
137
138 (* Main scanning function for filesystems. *)
139 let scan_machine ({ m_disks = m_disks } as machine) =
140   let m_disks = List.map (
141     fun ({ d_dev = dev } as disk) ->
142       let dev = (dev :> device) in
143       (* See if it is partitioned first. *)
144       let parts = probe_for_partitions dev in
145       match parts with
146       | Some parts ->
147           { disk with d_content = `Partitions parts }
148       | None ->
149           (* Not partitioned.  Does it contain a filesystem? *)
150           let fs = probe_for_filesystem dev in
151           match fs with
152           | Some fs ->
153               { disk with d_content = `Filesystem fs }
154           | None ->
155               (* Not partitioned, no filesystem, is it a PV? *)
156               let pv = probe_for_pv dev in
157               match pv with
158               | Some lvm_name ->
159                   { disk with d_content = `PhysicalVolume lvm_name }
160               | None ->
161                   disk (* Spare/unknown. *)
162   ) m_disks in
163
164   (* Now we have either detected partitions or a filesystem on each
165    * physical device (or perhaps neither).  See what is on those
166    * partitions.
167    *)
168   let m_disks = List.map (
169     function
170     | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
171         let ps = List.map (
172           fun p ->
173             if p.part_status = Bootable || p.part_status = Nonbootable then (
174               let fs = probe_for_filesystem p.part_dev in
175               match fs with
176               | Some fs ->
177                   { p with part_content = `Filesystem fs }
178               | None ->
179                   (* Is it a PV? *)
180                   let pv = probe_for_pv p.part_dev in
181                   match pv with
182                   | Some lvm_name ->
183                       { p with part_content = `PhysicalVolume lvm_name }
184                   | None ->
185                       p (* Spare/unknown. *)
186             ) else p
187         ) parts.parts in
188         let parts = { parts with parts = ps } in
189         { disk with d_content = `Partitions parts }
190     | disk -> disk
191   ) m_disks in
192
193   (* LVM filesystem detection
194    *
195    * Look for all disks/partitions which have been identified as PVs
196    * and pass those back to the respective LVM plugin for LV detection.
197    *
198    * (Note - a two-stage process because an LV can be spread over
199    * several PVs, so we have to detect all PVs belonging to a
200    * domain first).
201    *
202    * XXX To deal with RAID (ie. md devices) we will need to loop
203    * around here because RAID is like LVM except that they normally
204    * present as block devices which can be used by LVM.
205    *)
206   (* First: LV detection.
207    * Find all physical volumes, can be disks or partitions.
208    *)
209   let pvs_on_disks = List.filter_map (
210     function
211     | { d_dev = d_dev;
212         d_content = `PhysicalVolume pv } -> Some (pv, (d_dev :> device))
213     | _ -> None
214   ) m_disks in
215   let pvs_on_partitions = List.map (
216     function
217     | { d_content = `Partitions { parts = parts } } ->
218         List.filter_map (
219           function
220           | { part_dev = part_dev;
221               part_content = `PhysicalVolume pv } ->
222               Some (pv, part_dev)
223           | _ -> None
224         ) parts
225     | _ -> []
226   ) m_disks in
227   let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in
228
229   (* Second: filesystem on LV detection.
230    * Group the LVs by plug-in type.
231    *)
232   let cmp (a,_) (b,_) = compare a b in
233   let lvs = List.sort ~cmp lvs in
234   let lvs = group_by lvs in
235
236   let lvs =
237     List.map (fun (pv, devs) -> list_lvs pv.lvm_plugin_id devs) lvs in
238   let lvs = List.concat lvs in
239
240   (* lvs is a list of potential LV devices.  Now run them through the
241    * probes to see if any contain filesystems.
242    *)
243   let filesystems =
244     List.filter_map (
245       fun ({ lv_dev = dev } as lv) ->
246         match probe_for_filesystem dev with
247         | Some fs -> Some (lv, fs)
248         | None -> None
249     ) lvs in
250
251   { machine with
252       m_disks = m_disks;
253       m_lv_filesystems = filesystems }
254
255 (*----------------------------------------------------------------------*)
256
257 (* We describe the ownership of each part of the disk using a
258  * segment tree. http://en.wikipedia.org/wiki/Segment_tree
259  *
260  * Note that each part can (and usually is) owned multiple times
261  * (eg. by a filesystem and by the partition that the filesystem
262  * lies inside).  Also, the segment tree is effectively read-only.
263  * We build it up as a final step given the flat list of segments
264  * identified by the algorithm in 'iter_over_machine'.
265  *)
266
267 (* General binary tree type.  Data 'a is stored in the leaves and 'b
268  * is stored in the nodes.
269  *)
270 type ('a,'b) binary_tree =
271   | Leaf of 'a
272   | Node of ('a,'b) binary_tree * 'b * ('a,'b) binary_tree
273
274 (* This prints out the binary tree in graphviz dot format. *)
275 let print_binary_tree leaf_printer node_printer tree =
276   (* Assign a unique, fixed label to each node. *)
277   let label =
278     let i = ref 0 in
279     let hash = Hashtbl.create 13 in
280     fun node ->
281       try Hashtbl.find hash node
282       with Not_found ->
283         let i = incr i; !i in
284         let label = "n" ^ string_of_int i in
285         Hashtbl.add hash node label;
286         label
287   in
288   (* Recursively generate the graphviz file. *)
289   let rec print = function
290     | (Leaf a as leaf) ->
291         eprintf "  %s [shape=box, label=\"%s\"];\n"
292           (label leaf) (leaf_printer a)
293     | (Node (left,b,right) as node) ->
294         eprintf "  %s [label=\"%s\"];\n"
295           (label node) (node_printer b);
296         eprintf "  %s -> %s [tailport=sw];\n" (label node) (label left);
297         eprintf "  %s -> %s [tailport=se];\n" (label node) (label right);
298         print left;
299         print right;
300   in
301   eprintf "/* Use 'dot -Tpng foo.dot > foo.png' to convert to a png file. */\n";
302   eprintf "digraph G {\n";
303   print tree;
304   eprintf "}\n";
305
306 type owner =
307     [ `Filesystem of filesystem
308     | `Partitions of partitions
309     | `PhysicalVolume of pv ]
310
311 (* A segment describes the owner of a range of disk addresses. *)
312 type segment =
313     int63 * int63 *                     (* disk offset, size of segment *)
314       owner *                           (* owner *)
315       int63                             (* owner offset *)
316
317 type interval = int63 * int63           (* start point, end point (bytes) *)
318
319 (* The special segment tree structure that we construct in create_ownership. *)
320 type segment_tree =
321     (interval * segment list, interval * segment list) binary_tree
322
323 type ownership =
324     (device *                           (* block_device (disk) *)
325        segment_tree) list               (* segment tree for this disk *)
326
327 (* List of owned segments before we build the segment tree. *)
328 type ownership_list =
329     (device *                           (* block_device (disk) *)
330        segment) list
331
332 (* Ownership tables. *)
333 let create_ownership machine =
334   (* Iterate over all the things which can claim ownership of a
335    * disk block (filesystems, partitions, PVs).
336    *)
337   let rec iter_over_machine
338       ({m_disks = disks; m_lv_filesystems = lv_filesystems} as machine) =
339
340     (* No segments to begin with. *)
341     let ownership = [] in
342
343     (* Iterate over disks. *)
344     let ownership =
345       List.fold_left (
346         fun ownership ->
347           function
348           | { d_content = (`Filesystem fs as owner) } ->
349               iter_over_filesystem machine ownership fs owner
350           | { d_content = (`Partitions parts as owner) } ->
351               iter_over_partitions machine ownership parts owner
352           | { d_content = (`PhysicalVolume pv as owner) } ->
353               iter_over_pv machine ownership pv owner
354           | { d_content = `Unknown } -> ownership
355       ) ownership disks in
356
357     (* Iterate over LV filesystems. *)
358     let ownership =
359       List.fold_left (
360         fun ownership (lv, fs) ->
361           let owner = `Filesystem fs in
362           iter_over_filesystem machine ownership fs owner
363       ) ownership lv_filesystems in
364
365     ownership
366
367   (* Iterate over the blocks in a single filesystem. *)
368   and iter_over_filesystem machine ownership {fs_dev = dev} owner =
369     iter_over_device machine ownership dev owner
370
371   (* Iterate over the blocks in a set of partitions, then
372    * iterate over the contents of the partitions.
373    *)
374   and iter_over_partitions machine ownership
375       {parts = parts; parts_dev = parts_dev} owner =
376     let ownership = iter_over_device machine ownership parts_dev owner in
377
378     let ownership =
379       List.fold_left (
380         fun ownership ->
381           function
382           | { part_content = (`Filesystem fs as owner) } ->
383               iter_over_filesystem machine ownership fs owner
384           | { part_content = (`PhysicalVolume pv as owner) } ->
385               iter_over_pv machine ownership pv owner
386           | { part_content = `Unknown } -> ownership
387       ) ownership parts in
388
389     ownership
390
391   (* Iterate over the blocks in a PV. *)
392   and iter_over_pv machine ownership {pv_dev = dev} owner =
393     iter_over_device machine ownership dev owner
394
395   (* Iterate over the blocks in a device, assigning ownership to 'owner'
396    *
397    * In reality (1): There can be several owners for each block, so we
398    * incrementally add ownership to the ownership_list (which eventually
399    * will be turned into a segment tree).
400    * In reality (2): Iterating over blocks would take ages and result
401    * in a very inefficient ownership representation.  Instead we look
402    * at minimum contiguous extents.
403    *)
404   and iter_over_device { m_disks = disks } ownership dev owner =
405     let size = dev#size in
406     let disks = List.map (fun {d_dev = dev} -> (dev :> device)) disks in
407
408     let rec loop ownership offset =
409       if offset < size then (
410         let devs, extent = get_next_extent disks dev offset in
411         if devs = [] then
412           eprintf "warning: no device found under %s\n"
413             (string_of_owner owner);
414         let ownership =
415           List.fold_left (
416             fun ownership (disk, disk_offset) ->
417               let elem = disk, (disk_offset, extent, owner, offset) in
418               elem :: ownership
419           ) ownership devs in
420         loop ownership (offset +^ extent)
421       )
422       else ownership
423     in
424     loop ownership ~^0
425
426   (* Return the length of the next contiguous region in the device starting
427    * at the given byte offset.  Also return the underlying block device(s)
428    * if there is one.
429    *)
430   and get_next_extent disks (dev : device) offset =
431     let this_extent = dev#contiguous offset in
432
433     (* If this disk is a block_device (a member of the 'disks' list)
434      * then we've hit the bottom layer of devices, so just return it.
435      *)
436     if List.memq dev disks then
437       [dev, offset], this_extent
438     else (
439       let blocksize = dev#blocksize in
440       let block = offset /^ blocksize in
441       let offset_in_block = offset -^ block *^ blocksize in
442
443       (* Map from this block to the devices one layer down. *)
444       let devs = dev#map_block block in
445
446       (* Get the real device offsets, adding the offset from start of block. *)
447       let devs =
448         List.map
449           (fun (dev, dev_offset) -> dev, dev_offset +^ offset_in_block)
450           devs in
451
452       let devs =
453         List.map
454           (fun (dev, dev_offset) ->
455              get_next_extent disks dev dev_offset)
456           devs in
457
458       (* Work out the minimum contiguous extent from this offset. *)
459       let devs, extent =
460         let extents = List.map snd devs in
461         let devs = List.concat (List.map fst devs) in
462         let extent = List.fold_left min this_extent extents in
463         devs, extent in
464
465       devs, extent
466     )
467
468   and string_of_owner = function
469     | `Filesystem {fs_plugin_id = fs_plugin_id; fs_dev = fs_dev} ->
470         sprintf "%s(%s)" fs_dev#name fs_plugin_id
471     | `PhysicalVolume { pv_uuid = pv_uuid } ->
472         "PV:" ^ pv_uuid
473     | `Partitions { parts_plugin_id = parts_plugin_id } ->
474         parts_plugin_id
475   in
476
477   (* Build the list of segments. *)
478   let ownership : ownership_list = iter_over_machine machine in
479
480   (* Group the segments together by disk. *)
481   let ownership =
482     let ownership = List.sort ownership in
483     group_by ownership in
484
485   (* If debugging, print the segments that we found. *)
486   if !debug then (
487     List.iter (
488       fun (disk, segments) ->
489         eprintf "ownership segment list of %s %s:\n" machine.m_name disk#name;
490         List.iter (
491           fun (disk_offset, size, owner, owner_offset) ->
492             let blocksize = disk#blocksize in
493             let disk_offset_in_blocks, disk_offset_in_block =
494               disk_offset /^ blocksize, disk_offset %^ blocksize in
495             let size_in_blocks, size_in_block =
496               size /^ blocksize, size %^ blocksize in
497
498             eprintf "  %s[%s:%s] %s[%s:%s] %s@%s\n"
499               (Int63.to_string disk_offset)
500                 (Int63.to_string disk_offset_in_blocks)
501                 (Int63.to_string disk_offset_in_block)
502               (Int63.to_string size)
503                 (Int63.to_string size_in_blocks)
504                 (Int63.to_string size_in_block)
505               (string_of_owner owner)
506               (Int63.to_string owner_offset)
507         ) segments
508     ) ownership
509   );
510
511   (* Build the segment tree from the ownership list (of segments).
512    * For an explanation of this process see:
513    * http://en.wikipedia.org/wiki/Segment_tree
514    *)
515   let ownership =
516     List.map (
517       fun (disk, segments) ->
518         (* Construct the list of distinct endpoints. *)
519         let eps =
520           List.map
521             (fun (start, size, _, _) -> [start; start +^ size])
522             segments in
523         let eps = sort_uniq (List.concat eps) in
524
525         (* Construct the elementary intervals. *)
526         let elints =
527           let elints, lastpoint =
528             List.fold_left (
529               fun (elints, prevpoint) point ->
530                 ((point, point) :: (prevpoint, point) :: elints), point
531             ) ([], Int63.min_int) eps in
532           let elints = (lastpoint, Int63.max_int) :: elints in
533           List.rev elints in
534
535         if !debug then (
536           eprintf "elementary intervals for %s (%d in total):\n"
537             disk#name (List.length elints);
538           List.iter (
539             fun (startpoint, endpoint) ->
540               eprintf "  %s %s\n"
541                 (Int63.to_string startpoint) (Int63.to_string endpoint)
542           ) elints
543         );
544
545         (* Construct the binary tree of elementary intervals. *)
546         let tree =
547           (* Each elementary interval becomes a leaf. *)
548           let elints = List.map (fun elint -> Leaf elint) elints in
549           (* Recursively build this into a binary tree. *)
550           let rec make_layer = function
551             | [] -> []
552             | ([_] as x) -> x
553             (* Turn pairs of leaves at the bottom level into nodes. *)
554             | (Leaf _ as a) :: (Leaf _ as b) :: xs ->
555                 let xs = make_layer xs in
556                 Node (a, (), b) :: xs
557             (* Turn pairs of nodes at higher levels into nodes. *)
558             | (Node _ as left) :: ((Node _|Leaf _) as right) :: xs ->
559                 let xs = make_layer xs in
560                 Node (left, (), right) :: xs
561             | Leaf _ :: _ -> assert false (* never happens??? (I think) *)
562           in
563           let rec loop = function
564             | [] -> assert false
565             | [x] -> x
566             | xs -> loop (make_layer xs)
567           in
568           loop elints in
569
570         if !debug then (
571           let leaf_printer (startpoint, endpoint) =
572             sprintf "%s-%s"
573               (Int63.to_string startpoint) (Int63.to_string endpoint)
574           in
575           let node_printer () = "" in
576           print_binary_tree leaf_printer node_printer tree
577         );
578
579         (* Insert the segments into the tree one by one. *)
580         let tree =
581           (* For each node/leaf in the tree, add its interval and an
582            * empty list which will be used to store the segments.
583            *)
584           let rec interval_tree = function
585             | Leaf elint -> Leaf (elint, [])
586             | Node (left, (), right) ->
587                 let left = interval_tree left in
588                 let right = interval_tree right in
589                 let (leftstart, _) = interval_of_node left in
590                 let (_, rightend) = interval_of_node right in
591                 let interval = leftstart, rightend in
592                 Node (left, (interval, []), right)
593           and interval_of_node = function
594             | Leaf (elint, _) -> elint
595             | Node (_, (interval, _), _) -> interval
596           in
597
598           let tree = interval_tree tree in
599           (* This should always be true: *)
600           assert (interval_of_node tree = (Int63.min_int, Int63.max_int));
601
602           (* "Contained in" operator.
603            * 'a <-< b' iff 'a' is a subinterval of 'b'.
604            *      |<---- a ---->|
605            * |<----------- b ----------->|
606            *)
607           let (<-<) (a1, a2) (b1, b2) = b1 <= a1 && a2 <= b2 in
608
609           (* "Intersects" operator.
610            * 'a /\ b' iff intervals 'a' and 'b' overlap, eg:
611            *      |<---- a ---->|
612            *                |<----------- b ----------->|
613            *)
614           let ( /\ ) (a1, a2) (b1, b2) = a2 > b1 || b2 > a1 in
615
616           let rec insert_segment tree segment =
617             let start, size, owner, owner_offset = segment in
618             let seginterval = start, start +^ size in
619             eprintf "inserting (%s,%s) ...\n"
620               (Int63.to_string (fst seginterval))
621               (Int63.to_string (snd seginterval));
622             match tree with
623             (* Test if we should insert into this leaf or node: *)
624             | Leaf (interval, segs) when interval <-< seginterval ->
625                 Leaf (interval, segment :: segs)
626             | Node (left, (interval, segs), right)
627                 when interval <-< seginterval ->
628                 Node (left, (interval, segment :: segs), right)
629
630             | (Leaf _) as leaf -> leaf
631
632             (* Else, should we insert into left or right subtrees? *)
633             | Node (left, i, right) ->
634                 let left =
635                   if seginterval /\ interval_of_node left then
636                     insert_segment left segment
637                   else
638                     left in
639                 let right =
640                   if seginterval /\ interval_of_node right then
641                     insert_segment right segment
642                   else
643                     right in
644                 Node (left, i, right)
645           in
646           let tree = List.fold_left insert_segment tree segments in
647           tree in
648
649         if !debug then (
650           let printer ((sp, ep), segments) =
651             sprintf "[%s-%s] " (Int63.to_string sp) (Int63.to_string ep) ^
652               String.concat ";"
653               (List.map (fun (_, _, owner,_) -> string_of_owner owner)
654                  segments)
655           in
656           print_binary_tree printer printer tree
657         );
658         (disk, tree)
659     ) ownership in
660
661   (* Return the ownership structure. *)
662   ownership
663
664 let get_owners_lookup machine ownership disk =
665   (* Get the correct tree. *)
666   let tree = List.assoc disk ownership in
667
668   fun offset ->
669     let rec query = function
670       | Leaf (_, segments) -> segments
671       | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
672               (_, segments),
673               right) ->
674           let subsegments =
675             if offset < leftend then query left else query right in
676           segments @ subsegments
677     in
678     let owners = query tree in
679
680     List.map (
681       fun (_, _, owner, owner_offset) -> (owner, offset -^ owner_offset)
682     ) owners