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 let debug = ref false
  24
  25 let ( +* ) = Int32.add
  26 let ( -* ) = Int32.sub
  27 let ( ** ) = Int32.mul
  28 let ( /* ) = Int32.div
  29
  30 let ( +^ ) = Int64.add
  31 let ( -^ ) = Int64.sub
  32 let ( *^ ) = Int64.mul
  33 let ( /^ ) = Int64.div
  34
  35 class virtual device =
  36 object (self)
  37   method virtual read : int64 -> int -> string
  38   method virtual size : int64
  39   method virtual name : string
  40
  41   method close () = ()
  42
  43   (* Helper method to read a chunk of data into a bitstring. *)
  44   method read_bitstring offset len =
  45     let str = self#read offset len in
  46     (str, 0, len * 8)
  47 end
  48
  49 (* A concrete device which just direct-maps a file or /dev device. *)
  50 class block_device filename =
  51   let fd = openfile filename [ O_RDONLY ] 0 in
  52   let size = (LargeFile.fstat fd).LargeFile.st_size in
  53 object (self)
  54   inherit device
  55   method read offset len =
  56     ignore (LargeFile.lseek fd offset SEEK_SET);
  57     let str = String.make len '\000' in
  58     read fd str 0 len;
  59     str
  60   method close () = close fd
  61   method size = size
  62   method name = filename
  63 end
  64
  65 (* A linear offset/size from an underlying device. *)
  66 class offset_device name start size (dev : device) =
  67 object
  68   inherit device
  69   method name = name
  70   method size = size
  71   (* method close () = dev#close () - NB: NO!!  Device may be shared. *)
  72   method read offset len =
  73     if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then
  74       invalid_arg (
  75         sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)"
  76           name offset len size
  77       );
  78     dev#read (start+^offset) len
  79 end
  80
  81 (* The null device.  Any attempt to read generates an error. *)
  82 let null_device : device =
  83 object
  84   inherit device
  85   method read _ _ = assert false
  86   method size = 0L
  87   method name = "null"
  88 end
  89
  90 type machine = {
  91   m_name : string;                      (* Machine name. *)
  92   m_disks : disk list;                  (* Machine disks. *)
  93   m_lv_filesystems :
  94     (lv * filesystem) list;             (* Machine LV filesystems. *)
  95 }
  96 and disk = {
  97   d_name : string;                      (* Device name (eg "hda") *)
  98
  99   (* About the device itself. *)
 100   d_dev : device;                       (* Disk device. *)
 101   d_content : disk_content;             (* What's on it. *)
 102 }
 103 and disk_content =
 104   [ `Unknown                            (* Not probed or unknown. *)
 105   | `Partitions of partitions           (* Contains partitions. *)
 106   | `Filesystem of filesystem           (* Contains a filesystem directly. *)
 107   | `PhysicalVolume of pv               (* Contains an LVM PV. *)
 108   ]
 109
 110 (* Partitions. *)
 111
 112 and partitions = {
 113   parts_name : string;                  (* Name of partitioning scheme. *)
 114   parts : partition list                (* Partitions. *)
 115 }
 116 and partition = {
 117   part_status : partition_status;       (* Bootable, etc. *)
 118   part_type : int;                      (* Partition filesystem type. *)
 119   part_dev : device;                    (* Partition device. *)
 120   part_content : partition_content;     (* What's on it. *)
 121 }
 122 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
 123 and partition_content =
 124   [ `Unknown                            (* Not probed or unknown. *)
 125   | `Filesystem of filesystem           (* Filesystem. *)
 126   | `PhysicalVolume of pv               (* Contains an LVM PV. *)
 127   ]
 128
 129 (* Filesystems (also swap devices). *)
 130 and filesystem = {
 131   fs_name : string;                     (* Name of filesystem. *)
 132   fs_block_size : int64;                (* Block size (bytes). *)
 133   fs_blocks_total : int64;              (* Total blocks. *)
 134   fs_is_swap : bool;                    (* If swap, following not valid. *)
 135   fs_blocks_reserved : int64;           (* Blocks reserved for super-user. *)
 136   fs_blocks_avail : int64;              (* Blocks free (available). *)
 137   fs_blocks_used : int64;               (* Blocks in use. *)
 138   fs_inodes_total : int64;              (* Total inodes. *)
 139   fs_inodes_reserved : int64;           (* Inodes reserved for super-user. *)
 140   fs_inodes_avail : int64;              (* Inodes free (available). *)
 141   fs_inodes_used : int64;               (* Inodes in use. *)
 142 }
 143
 144 (* Physical volumes. *)
 145 and pv = {
 146   lvm_plugin_id : lvm_plugin_id;        (* The LVM plug-in. *)
 147   pv_uuid : string;                     (* UUID. *)
 148 }
 149
 150 (* Logical volumes. *)
 151 and lv = {
 152   lv_dev : device;                      (* Logical volume device. *)
 153 }
 154
 155 and lvm_plugin_id = string
 156
 157 (* Convert partition, filesystem types to printable strings for debugging. *)
 158 let string_of_partition
 159     { part_status = status; part_type = typ; part_dev = dev } =
 160   sprintf "%s: %s partition type %d"
 161     dev#name
 162     (match status with
 163      | Bootable -> "bootable"
 164      | Nonbootable -> "nonbootable"
 165      | Malformed -> "malformed"
 166      | NullEntry -> "empty")
 167     typ
 168
 169 let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
 170   if not swap then name
 171   else name ^ " [swap]"
 172
 173 (* Convert a UUID (containing '-' chars) to canonical form. *)
 174 let canonical_uuid uuid =
 175   let uuid' = String.make 32 ' ' in
 176   let j = ref 0 in
 177   for i = 0 to String.length uuid - 1 do
 178     if !j >= 32 then invalid_arg "canonical_uuid";
 179     let c = uuid.[i] in
 180     if c <> '-' then ( uuid'.[!j] <- c; incr j )
 181   done;
 182   if !j <> 32 then invalid_arg "canonical_uuid";
 183   uuid'
 184
 185 (* This version by Isaac Trotts. *)
 186 let group_by ?(cmp = Pervasives.compare) ls =
 187   let ls' =
 188     List.fold_left
 189       (fun acc (day1, x1) ->
 190          match acc with
 191              [] -> [day1, [x1]]
 192            | (day2, ls2) :: acctl ->
 193                if cmp day1 day2 = 0
 194                then (day1, x1 :: ls2) :: acctl
 195                else (day1, [x1]) :: acc)
 196       []
 197       ls
 198   in
 199   let ls' = List.rev ls' in
 200   List.map (fun (x, xs) -> x, List.rev xs) ls'
 201
 202 let rec range a b =
 203   if a < b then a :: range (a+1) b
 204   else []