lib/diskimage_utils.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 Unix
  22
  23 open Int63.Operators
  24
  25 let debug = ref false
  26
  27 class virtual device =
  28 object (self)
  29   method virtual size : int63
  30   method virtual name : string
  31   method virtual blocksize : int63
  32   method virtual map_block : int63 -> (device * int63) list
  33   method virtual contiguous : Int63.t -> Int63.t
  34
  35   (* Block-based read.  Inefficient so normally overridden in subclasses. *)
  36   method read offset len =
  37     if offset < ~^0 || len < ~^0 then
  38       invalid_arg "device: read: negative offset or length";
  39
  40     let blocksize = self#blocksize in
  41
  42     (* Break the request into blocks.
  43      * Find the first and last blocks of this request.
  44      *)
  45     let first_blk = offset /^ blocksize in
  46     let offset_in_first_blk = offset -^ first_blk *^ blocksize in
  47     let last_blk = (offset +^ len -^ ~^1) /^ blocksize in
  48
  49     (* Buffer for the result. *)
  50     let buf = Buffer.create (Int63.to_int len) in
  51
  52     let not_mapped_error () = invalid_arg "device: read: block not mapped" in
  53
  54     (* Copy the first block (partial). *)
  55     (match self#map_block first_blk with
  56      | [] -> not_mapped_error ()
  57      | (dev, base) :: _ ->
  58          let len =
  59            min len (blocksize -^ offset_in_first_blk) in
  60          let str = dev#read (base +^ offset_in_first_blk) len in
  61          Buffer.add_string buf str
  62     );
  63
  64     (* Copy the middle blocks. *)
  65     let rec loop blk =
  66       if blk < last_blk then (
  67         (match self#map_block blk with
  68          | [] -> not_mapped_error ()
  69          | (dev, base) :: _ ->
  70              let str = dev#read ~^0 self#blocksize in
  71              Buffer.add_string buf str
  72         );
  73         loop (Int63.succ blk)
  74       )
  75     in
  76     loop (Int63.succ first_blk);
  77
  78     (* Copy the last block (partial). *)
  79     if first_blk < last_blk then (
  80       match self#map_block last_blk with
  81       | [] -> not_mapped_error ()
  82       | (dev, base) :: _ ->
  83           let len = (offset +^ len) -^ last_blk *^ blocksize in
  84           let str = dev#read ~^0 len in
  85           Buffer.add_string buf str
  86     );
  87
  88     assert (Int63.to_int len = Buffer.length buf);
  89     Buffer.contents buf
  90
  91   (* Helper method to read a chunk of data into a bitstring. *)
  92   method read_bitstring offset len =
  93     let str = self#read offset len in
  94     (str, 0, String.length str lsl 3)
  95 end
  96
  97 (* A concrete device which just direct-maps a file or /dev device. *)
  98 class block_device filename blocksize =
  99   let fd = openfile filename [ O_RDONLY ] 0 in
 100   let size = Int63.of_int64 (LargeFile.fstat fd).LargeFile.st_size in
 101 object (self)
 102   inherit device
 103   method read offset len =
 104     let offset = Int63.to_int64 offset in
 105     let len = Int63.to_int len in
 106     ignore (LargeFile.lseek fd offset SEEK_SET);
 107     let str = String.make len '\000' in
 108     read fd str 0 len;
 109     str
 110   method size = size
 111   method name = filename
 112   method blocksize = blocksize
 113   method map_block _ = []
 114   method contiguous offset =
 115     size -^ offset
 116   method close () = close fd
 117 end
 118
 119 (* A linear offset/size from an underlying device. *)
 120 class offset_device name start size blocksize (dev : device) =
 121 object
 122   inherit device
 123   method name = name
 124   method size = size
 125   method read offset len =
 126     if offset < ~^0 || len < ~^0 || offset +^ len > size then
 127       invalid_arg (
 128         sprintf "%s: tried to read outside device boundaries (%s/%s/%s)"
 129           name (Int63.to_string offset) (Int63.to_string len)
 130           (Int63.to_string size)
 131       );
 132     dev#read (start+^offset) len
 133   method blocksize = blocksize
 134   method map_block i = [dev, i *^ blocksize +^ start]
 135   method contiguous offset =
 136     size -^ offset
 137 end
 138
 139 (* A device with just a modified block size. *)
 140 class blocksize_overlay new_blocksize (dev : device) =
 141 object
 142   inherit device
 143   method name = dev#name
 144   method size = dev#size
 145   method read = dev#read
 146   method blocksize = new_blocksize
 147   method map_block new_blk =
 148     let orig_blk = new_blk *^ new_blocksize /^ dev#blocksize in
 149     dev#map_block orig_blk
 150   method contiguous offset = dev#size -^ offset
 151 end
 152
 153 (* The null device.  Any attempt to read generates an error. *)
 154 let null_device : device =
 155 object
 156   inherit device
 157   method read _ _ = assert false
 158   method size = ~^0
 159   method name = "null"
 160   method blocksize = ~^1
 161   method map_block _ = assert false
 162   method contiguous _ = ~^0
 163 end
 164
 165 type machine = {
 166   m_name : string;                      (* Machine name. *)
 167   m_disks : disk list;                  (* Machine disks. *)
 168   m_lv_filesystems :
 169     (lv * filesystem) list;             (* Machine LV filesystems. *)
 170 }
 171 and disk = {
 172   d_name : string;                      (* Device name (eg "hda") *)
 173
 174   (* About the device itself. *)
 175   d_dev : block_device;                 (* Disk device. *)
 176   d_content : disk_content;             (* What's on it. *)
 177 }
 178 and disk_content =
 179   [ `Unknown                            (* Not probed or unknown. *)
 180   | `Partitions of partitions           (* Contains partitions. *)
 181   | `Filesystem of filesystem           (* Contains a filesystem directly. *)
 182   | `PhysicalVolume of pv               (* Contains an LVM PV. *)
 183   ]
 184
 185 (* Partitions. *)
 186
 187 and partitions = {
 188   parts_plugin_id : parts_plugin_id;    (* Partitioning scheme. *)
 189   parts_dev : device;                   (* Partitions (whole) device. *)
 190   parts : partition list                (* Partitions. *)
 191 }
 192 and partition = {
 193   part_status : partition_status;       (* Bootable, etc. *)
 194   part_type : int;                      (* Partition filesystem type. *)
 195   part_dev : device;                    (* Partition device. *)
 196   part_content : partition_content;     (* What's on it. *)
 197 }
 198 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
 199 and partition_content =
 200   [ `Unknown                            (* Not probed or unknown. *)
 201   | `Filesystem of filesystem           (* Filesystem. *)
 202   | `PhysicalVolume of pv               (* Contains an LVM PV. *)
 203   ]
 204
 205 (* Filesystems (also swap devices). *)
 206 and filesystem = {
 207   fs_plugin_id : fs_plugin_id;          (* Filesystem. *)
 208   fs_dev : device;                      (* Device containing the filesystem. *)
 209   fs_blocksize : int63;                 (* Block size (bytes). *)
 210   fs_blocks_total : int63;              (* Total blocks. *)
 211   fs_is_swap : bool;                    (* If swap, following not valid. *)
 212   fs_blocks_reserved : int63;           (* Blocks reserved for super-user. *)
 213   fs_blocks_avail : int63;              (* Blocks free (available). *)
 214   fs_blocks_used : int63;               (* Blocks in use. *)
 215   fs_inodes_total : int63;              (* Total inodes. *)
 216   fs_inodes_reserved : int63;           (* Inodes reserved for super-user. *)
 217   fs_inodes_avail : int63;              (* Inodes free (available). *)
 218   fs_inodes_used : int63;               (* Inodes in use. *)
 219 }
 220
 221 (* Physical volumes. *)
 222 and pv = {
 223   lvm_plugin_id : lvm_plugin_id;        (* The LVM plug-in. *)
 224   pv_dev : device;                      (* Device covering whole PV. *)
 225   pv_uuid : string;                     (* UUID. *)
 226 }
 227
 228 (* Logical volumes. *)
 229 and lv = {
 230   lv_dev : device;                      (* Logical volume device. *)
 231 }
 232
 233 and parts_plugin_id = string
 234 and fs_plugin_id = string
 235 and lvm_plugin_id = string
 236
 237 (* Convert a UUID (containing '-' chars) to canonical form. *)
 238 let canonical_uuid uuid =
 239   let uuid' = String.make 32 ' ' in
 240   let j = ref 0 in
 241   for i = 0 to String.length uuid - 1 do
 242     if !j >= 32 then invalid_arg "canonical_uuid";
 243     let c = uuid.[i] in
 244     if c <> '-' then ( uuid'.[!j] <- c; incr j )
 245   done;
 246   if !j <> 32 then invalid_arg "canonical_uuid";
 247   uuid'
 248
 249 (* This version by Isaac Trotts. *)
 250 let group_by ?(cmp = Pervasives.compare) ls =
 251   let ls' =
 252     List.fold_left
 253       (fun acc (day1, x1) ->
 254          match acc with
 255              [] -> [day1, [x1]]
 256            | (day2, ls2) :: acctl ->
 257                if cmp day1 day2 = 0
 258                then (day1, x1 :: ls2) :: acctl
 259                else (day1, [x1]) :: acc)
 260       []
 261       ls
 262   in
 263   let ls' = List.rev ls' in
 264   List.map (fun (x, xs) -> x, List.rev xs) ls'
 265
 266 let rec uniq ?(cmp = Pervasives.compare) = function
 267   | [] -> []
 268   | [x] -> [x]
 269   | x :: y :: xs when cmp x y = 0 ->
 270       uniq (x :: xs)
 271   | x :: y :: xs ->
 272       x :: uniq (y :: xs)
 273
 274 let sort_uniq ?cmp xs =
 275   let xs = ExtList.List.sort ?cmp xs in
 276   let xs = uniq ?cmp xs in
 277   xs
 278
 279 let rec range a b =
 280   if a < b then a :: range (a+1) b
 281   else []