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 debug = true     (* If true emit lots of debugging information. *)
  27
  28 let ( +* ) = Int32.add
  29 let ( -* ) = Int32.sub
  30 let ( ** ) = Int32.mul
  31 let ( /* ) = Int32.div
  32
  33 let ( +^ ) = Int64.add
  34 let ( -^ ) = Int64.sub
  35 let ( *^ ) = Int64.mul
  36 let ( /^ ) = Int64.div
  37
  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
  44 class virtual device =
  45 object (self)
  46   method virtual read : int64 -> int -> string
  47   method virtual size : int64
  48   method virtual name : string
  49
  50   (* Helper method to read a chunk of data into a bitstring. *)
  51   method read_bitstring offset len =
  52     let str = self#read offset len in
  53     (str, 0, len * 8)
  54 end
  55
  56 (* A concrete device which just direct-maps a file or /dev device. *)
  57 class block_device filename =
  58   let fd = openfile filename [ O_RDONLY ] 0 in
  59   let size = (LargeFile.fstat fd).LargeFile.st_size in
  60 object (self)
  61   inherit device
  62   method read offset len =
  63     ignore (LargeFile.lseek fd offset SEEK_SET);
  64     let str = String.make len '\000' in
  65     read fd str 0 len;
  66     str
  67   method size = size
  68   method name = filename
  69 end
  70
  71 (* The null device.  Any attempt to read generates an error. *)
  72 let null_device : device =
  73 object
  74   inherit device
  75   method read _ _ = assert false
  76   method size = 0L
  77   method name = "null"
  78 end
  79
  80 type domain = {
  81   dom_name : string;                    (* Domain name. *)
  82   dom_id : int option;                  (* Domain ID (if running). *)
  83   dom_disks : disk list;                (* Domain disks. *)
  84 }
  85 and disk = {
  86   (* From the XML ... *)
  87   d_type : string option;               (* The <disk type=...> *)
  88   d_device : string;                    (* The <disk device=...> (eg "disk") *)
  89   d_source : string;                    (* The <source file=... or dev> *)
  90   d_target : string;                    (* The <target dev=...> (eg "hda") *)
  91
  92   (* About the device itself. *)
  93   d_dev : device;                       (* Disk device. *)
  94   d_content : disk_content;             (* What's on it. *)
  95 }
  96 and disk_content =
  97   [ `Unknown                            (* Not probed or unknown. *)
  98   | `Partitions of partitions           (* Contains partitions. *)
  99   | `Filesystem of filesystem           (* Contains a filesystem directly. *)
 100   | `PhysicalVolume of string           (* Contains an LVM PV. *)
 101   ]
 102
 103 (* Partitions. *)
 104
 105 and partitions = {
 106   parts_name : string;                  (* Name of partitioning scheme. *)
 107   parts : partition list                (* Partitions. *)
 108 }
 109 and partition = {
 110   part_status : partition_status;       (* Bootable, etc. *)
 111   part_type : int;                      (* Partition filesystem type. *)
 112   part_dev : device;                    (* Partition device. *)
 113   part_content : partition_content;     (* What's on it. *)
 114 }
 115 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
 116 and partition_content =
 117   [ `Unknown                            (* Not probed or unknown. *)
 118   | `Filesystem of filesystem           (* Filesystem. *)
 119   | `PhysicalVolume of string           (* Contains an LVM PV. *)
 120   ]
 121
 122 (* Filesystems (also swap devices). *)
 123 and filesystem = {
 124   fs_name : string;                     (* Name of filesystem. *)
 125   fs_block_size : int64;                (* Block size (bytes). *)
 126   fs_blocks_total : int64;              (* Total blocks. *)
 127   fs_is_swap : bool;                    (* If swap, following not valid. *)
 128   fs_blocks_reserved : int64;           (* Blocks reserved for super-user. *)
 129   fs_blocks_avail : int64;              (* Blocks free (available). *)
 130   fs_blocks_used : int64;               (* Blocks in use. *)
 131   fs_inodes_total : int64;              (* Total inodes. *)
 132   fs_inodes_reserved : int64;           (* Inodes reserved for super-user. *)
 133   fs_inodes_avail : int64;              (* Inodes free (available). *)
 134   fs_inodes_used : int64;               (* Inodes in use. *)
 135 }
 136
 137 (* Convert partition, filesystem types to printable strings for debugging. *)
 138 let string_of_partition
 139     { part_status = status; part_type = typ; part_dev = dev } =
 140   sprintf "%s: %s partition type %d"
 141     dev#name
 142     (match status with
 143      | Bootable -> "bootable"
 144      | Nonbootable -> "nonbootable"
 145      | Malformed -> "malformed"
 146      | NullEntry -> "empty")
 147     typ
 148
 149 let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
 150   if not swap then name
 151   else name ^ " [swap]"
 152
 153 (* Register a partition scheme. *)
 154 let partition_types = ref []
 155 let partition_type_register (parts_name : string) probe_fn =
 156   partition_types := (parts_name, probe_fn) :: !partition_types
 157
 158 (* Probe a device for partitions.  Returns [Some parts] or [None]. *)
 159 let probe_for_partitions dev =
 160   if debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
 161   let rec loop = function
 162     | [] -> None
 163     | (parts_name, probe_fn) :: rest ->
 164         try Some (probe_fn dev)
 165         with Not_found -> loop rest
 166   in
 167   let r = loop !partition_types in
 168   if debug then (
 169     match r with
 170     | None -> eprintf "no partitions found on %s\n%!" dev#name
 171     | Some { parts_name = name; parts = parts } ->
 172         eprintf "found %d %s partitions on %s:\n"
 173           (List.length parts) name dev#name;
 174         List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
 175   );
 176   r
 177
 178 (* Register a filesystem type (or swap). *)
 179 let filesystem_types = ref []
 180 let filesystem_type_register (fs_name : string) probe_fn =
 181   filesystem_types := (fs_name, probe_fn) :: !filesystem_types
 182
 183 (* Probe a device for a filesystem.  Returns [Some fs] or [None]. *)
 184 let probe_for_filesystem dev =
 185   if debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
 186   let rec loop = function
 187     | [] -> None
 188     | (fs_name, probe_fn) :: rest ->
 189         try Some (probe_fn dev)
 190         with Not_found -> loop rest
 191   in
 192   let r = loop !filesystem_types in
 193   if debug then (
 194     match r with
 195     | None -> eprintf "no filesystem found on %s\n%!" dev#name
 196     | Some fs ->
 197         eprintf "found a filesystem on %s:\n" dev#name;
 198         eprintf "\t%s\n%!" (string_of_filesystem fs)
 199   );
 200   r
 201
 202 (* Register a volume management type. *)
 203 let lvm_types = ref []
 204 let lvm_type_register (lvm_name : string) probe_fn list_lvs_fn =
 205   lvm_types := (lvm_name, (probe_fn, list_lvs_fn)) :: !lvm_types
 206
 207 (* Probe a device for a PV.  Returns [Some lvm_name] or [None]. *)
 208 let probe_for_pv dev =
 209   if debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
 210   let rec loop = function
 211     | [] -> None
 212     | (lvm_name, (probe_fn, _)) :: rest ->
 213         if probe_fn dev then Some lvm_name else loop rest
 214   in
 215   let r = loop !lvm_types in
 216   if debug then (
 217     match r with
 218     | None -> eprintf "no PV found on %s\n%!" dev#name
 219     | Some lvm_name ->
 220         eprintf "%s contains a %s PV\n%!" dev#name lvm_name
 221   );
 222   r