virt-df/virt_df.ml

   1 (* 'df' command for virtual domains.
   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 Virt_df_gettext.Gettext
  25
  26 let ( +* ) = Int32.add
  27 let ( -* ) = Int32.sub
  28 let ( ** ) = Int32.mul
  29 let ( /* ) = Int32.div
  30
  31 let ( +^ ) = Int64.add
  32 let ( -^ ) = Int64.sub
  33 let ( *^ ) = Int64.mul
  34 let ( /^ ) = Int64.div
  35
  36 (* Command line arguments. *)
  37 let debug = ref false
  38 let uri = ref None
  39 let inodes = ref false
  40 let human = ref false
  41 let all = ref false
  42 let test_files = ref []
  43 let csv_mode = ref false
  44
  45 (* Support for CSV (overridden by virt_df_csv.ml, if present). *)
  46 let csv_write = ref None
  47
  48 class virtual device =
  49 object (self)
  50   method virtual read : int64 -> int -> string
  51   method virtual size : int64
  52   method virtual name : string
  53
  54   (* Helper method to read a chunk of data into a bitstring. *)
  55   method read_bitstring offset len =
  56     let str = self#read offset len in
  57     (str, 0, len * 8)
  58 end
  59
  60 (* A concrete device which just direct-maps a file or /dev device. *)
  61 class block_device filename =
  62   let fd = openfile filename [ O_RDONLY ] 0 in
  63   let size = (LargeFile.fstat fd).LargeFile.st_size in
  64 object (self)
  65   inherit device
  66   method read offset len =
  67     ignore (LargeFile.lseek fd offset SEEK_SET);
  68     let str = String.make len '\000' in
  69     read fd str 0 len;
  70     str
  71   method size = size
  72   method name = filename
  73 end
  74
  75 (* A linear offset/size from an underlying device. *)
  76 class offset_device name start size (dev : device) =
  77 object
  78   inherit device
  79   method name = name
  80   method size = size
  81   method read offset len =
  82     if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then
  83       invalid_arg (
  84         sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)"
  85           name offset len size
  86       );
  87     dev#read (start+^offset) len
  88 end
  89
  90 (* The null device.  Any attempt to read generates an error. *)
  91 let null_device : device =
  92 object
  93   inherit device
  94   method read _ _ = assert false
  95   method size = 0L
  96   method name = "null"
  97 end
  98
  99 type domain = {
 100   dom_name : string;                    (* Domain name. *)
 101   dom_id : int option;                  (* Domain ID (if running). *)
 102   dom_disks : disk list;                (* Domain disks. *)
 103   dom_lv_filesystems :
 104     (lv * filesystem) list;             (* Domain LV filesystems. *)
 105 }
 106 and disk = {
 107   (* From the XML ... *)
 108   d_type : string option;               (* The <disk type=...> *)
 109   d_device : string;                    (* The <disk device=...> (eg "disk") *)
 110   d_source : string;                    (* The <source file=... or dev> *)
 111   d_target : string;                    (* The <target dev=...> (eg "hda") *)
 112
 113   (* About the device itself. *)
 114   d_dev : device;                       (* Disk device. *)
 115   d_content : disk_content;             (* What's on it. *)
 116 }
 117 and disk_content =
 118   [ `Unknown                            (* Not probed or unknown. *)
 119   | `Partitions of partitions           (* Contains partitions. *)
 120   | `Filesystem of filesystem           (* Contains a filesystem directly. *)
 121   | `PhysicalVolume of pv               (* Contains an LVM PV. *)
 122   ]
 123
 124 (* Partitions. *)
 125
 126 and partitions = {
 127   parts_name : string;                  (* Name of partitioning scheme. *)
 128   parts : partition list                (* Partitions. *)
 129 }
 130 and partition = {
 131   part_status : partition_status;       (* Bootable, etc. *)
 132   part_type : int;                      (* Partition filesystem type. *)
 133   part_dev : device;                    (* Partition device. *)
 134   part_content : partition_content;     (* What's on it. *)
 135 }
 136 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
 137 and partition_content =
 138   [ `Unknown                            (* Not probed or unknown. *)
 139   | `Filesystem of filesystem           (* Filesystem. *)
 140   | `PhysicalVolume of pv               (* Contains an LVM PV. *)
 141   ]
 142
 143 (* Filesystems (also swap devices). *)
 144 and filesystem = {
 145   fs_name : string;                     (* Name of filesystem. *)
 146   fs_block_size : int64;                (* Block size (bytes). *)
 147   fs_blocks_total : int64;              (* Total blocks. *)
 148   fs_is_swap : bool;                    (* If swap, following not valid. *)
 149   fs_blocks_reserved : int64;           (* Blocks reserved for super-user. *)
 150   fs_blocks_avail : int64;              (* Blocks free (available). *)
 151   fs_blocks_used : int64;               (* Blocks in use. *)
 152   fs_inodes_total : int64;              (* Total inodes. *)
 153   fs_inodes_reserved : int64;           (* Inodes reserved for super-user. *)
 154   fs_inodes_avail : int64;              (* Inodes free (available). *)
 155   fs_inodes_used : int64;               (* Inodes in use. *)
 156 }
 157
 158 (* Physical volumes. *)
 159 and pv = {
 160   lvm_plugin_id : lvm_plugin_id;        (* The LVM plug-in. *)
 161   pv_uuid : string;                     (* UUID. *)
 162 }
 163
 164 (* Logical volumes. *)
 165 and lv = {
 166   lv_dev : device;                      (* Logical volume device. *)
 167 }
 168
 169 and lvm_plugin_id = string
 170
 171 (* Convert partition, filesystem types to printable strings for debugging. *)
 172 let string_of_partition
 173     { part_status = status; part_type = typ; part_dev = dev } =
 174   sprintf "%s: %s partition type %d"
 175     dev#name
 176     (match status with
 177      | Bootable -> "bootable"
 178      | Nonbootable -> "nonbootable"
 179      | Malformed -> "malformed"
 180      | NullEntry -> "empty")
 181     typ
 182
 183 let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
 184   if not swap then name
 185   else name ^ " [swap]"
 186
 187 (* Convert a UUID (containing '-' chars) to canonical form. *)
 188 let canonical_uuid uuid =
 189   let uuid' = String.make 32 ' ' in
 190   let j = ref 0 in
 191   for i = 0 to String.length uuid - 1 do
 192     if !j >= 32 then
 193       invalid_arg (sprintf (f_ "canonical_uuid: UUID is too long: %s") uuid);
 194     let c = uuid.[i] in
 195     if c <> '-' then ( uuid'.[!j] <- c; incr j )
 196   done;
 197   if !j <> 32 then
 198     invalid_arg (sprintf (f_ "canonical_uuid: invalid UUID: %s") uuid);
 199   uuid'
 200
 201 (* Register a partition scheme. *)
 202 let partition_types = ref []
 203 let partition_type_register (parts_name : string) probe_fn =
 204   partition_types := (parts_name, probe_fn) :: !partition_types
 205
 206 (* Probe a device for partitions.  Returns [Some parts] or [None]. *)
 207 let probe_for_partitions dev =
 208   if !debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
 209   let rec loop = function
 210     | [] -> None
 211     | (parts_name, probe_fn) :: rest ->
 212         try Some (probe_fn dev)
 213         with Not_found -> loop rest
 214   in
 215   let r = loop !partition_types in
 216   if !debug then (
 217     match r with
 218     | None -> eprintf "no partitions found on %s\n%!" dev#name
 219     | Some { parts_name = name; parts = parts } ->
 220         eprintf "found %d %s partitions on %s:\n"
 221           (List.length parts) name dev#name;
 222         List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
 223   );
 224   r
 225
 226 (* Register a filesystem type (or swap). *)
 227 let filesystem_types = ref []
 228 let filesystem_type_register (fs_name : string) probe_fn =
 229   filesystem_types := (fs_name, probe_fn) :: !filesystem_types
 230
 231 (* Probe a device for a filesystem.  Returns [Some fs] or [None]. *)
 232 let probe_for_filesystem dev =
 233   if !debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
 234   let rec loop = function
 235     | [] -> None
 236     | (fs_name, probe_fn) :: rest ->
 237         try Some (probe_fn dev)
 238         with Not_found -> loop rest
 239   in
 240   let r = loop !filesystem_types in
 241   if !debug then (
 242     match r with
 243     | None -> eprintf "no filesystem found on %s\n%!" dev#name
 244     | Some fs ->
 245         eprintf "found a filesystem on %s:\n" dev#name;
 246         eprintf "\t%s\n%!" (string_of_filesystem fs)
 247   );
 248   r
 249
 250 (* Register a volume management type. *)
 251 let lvm_types = ref []
 252 let lvm_type_register (lvm_name : string) probe_fn list_lvs_fn =
 253   lvm_types := (lvm_name, (probe_fn, list_lvs_fn)) :: !lvm_types
 254
 255 (* Probe a device for a PV.  Returns [Some lvm_name] or [None]. *)
 256 let probe_for_pv dev =
 257   if !debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
 258   let rec loop = function
 259     | [] -> None
 260     | (lvm_name, (probe_fn, _)) :: rest ->
 261         try Some (probe_fn lvm_name dev)
 262         with Not_found -> loop rest
 263   in
 264   let r = loop !lvm_types in
 265   if !debug then (
 266     match r with
 267     | None -> eprintf "no PV found on %s\n%!" dev#name
 268     | Some { lvm_plugin_id = name } ->
 269         eprintf "%s contains a %s PV\n%!" dev#name name
 270   );
 271   r
 272
 273 let list_lvs lvm_name devs =
 274   let _, list_lvs_fn = List.assoc lvm_name !lvm_types in
 275   list_lvs_fn devs
 276
 277 (*----------------------------------------------------------------------*)
 278
 279 (* This version by Isaac Trotts. *)
 280 let group_by ?(cmp = Pervasives.compare) ls =
 281   let ls' =
 282     List.fold_left
 283       (fun acc (day1, x1) ->
 284          match acc with
 285              [] -> [day1, [x1]]
 286            | (day2, ls2) :: acctl ->
 287                if cmp day1 day2 = 0
 288                then (day1, x1 :: ls2) :: acctl
 289                else (day1, [x1]) :: acc)
 290       []
 291       ls
 292   in
 293   let ls' = List.rev ls' in
 294   List.map (fun (x, xs) -> x, List.rev xs) ls'
 295
 296 let rec range a b =
 297   if a < b then a :: range (a+1) b
 298   else []