summaryrefslogtreecommitdiffstats
path: root/virt-df/virt_df_main.ml
blob: e6ae53e42e439551ffe0f9e35ce871334899ab16 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
(* 'df' command for virtual domains.
   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
   http://libvirt.org/

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *)

open Printf
open ExtList
open Unix

module C = Libvirt.Connect
module D = Libvirt.Domain

open Virt_df_gettext.Gettext
open Virt_df

let () =
  (* Command line argument parsing. *)
  let set_uri = function "" -> uri := None | u -> uri := Some u in

  let version () =
    printf "virt-df %s\n" (Libvirt_version.version);

    let major, minor, release =
      let v, _ = Libvirt.get_version () in
      v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
    printf "libvirt %d.%d.%d\n" major minor release;
    exit 0
  in

  let test_mode filename =
    test_files := filename :: !test_files
  in

  let argspec = Arg.align [
    "-a", Arg.Set all,
      " " ^ s_ "Show all domains (default: only active domains)";
    "--all", Arg.Set all,
      " " ^ s_ "Show all domains (default: only active domains)";
    "-c", Arg.String set_uri,
      "uri " ^ s_ "Connect to URI (default: Xen)";
    "--connect", Arg.String set_uri,
      "uri " ^ s_ "Connect to URI (default: Xen)";
    "-h", Arg.Set human,
      " " ^ s_ "Print sizes in human-readable format";
    "--human-readable", Arg.Set human,
      " " ^ s_ "Print sizes in human-readable format";
    "-i", Arg.Set inodes,
      " " ^ s_ "Show inodes instead of blocks";
    "--inodes", Arg.Set inodes,
      " " ^ s_ "Show inodes instead of blocks";
    "-t", Arg.String test_mode,
      "dev" ^ s_ "(Test mode) Display contents of block device or file";
    "--version", Arg.Unit version,
      " " ^ s_ "Display version and exit";
  ] in

  let anon_fun str =
    raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
  let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests

SUMMARY
  virt-df [-options]

OPTIONS" in

  Arg.parse argspec anon_fun usage_msg;

  let doms : domain list =
    if !test_files = [] then (
      let xmls =
	(* Connect to the hypervisor. *)
	let conn =
	  let name = !uri in
	  try C.connect_readonly ?name ()
	  with
	    Libvirt.Virterror err ->
	      prerr_endline (Libvirt.Virterror.to_string err);
	      (* If non-root and no explicit connection URI, print a warning. *)
	      if geteuid () <> 0 && name = None then (
		print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
	      );
	      exit 1 in

	(* Get the list of active & inactive domains. *)
	let doms =
	  let nr_active_doms = C.num_of_domains conn in
	  let active_doms =
	    Array.to_list (C.list_domains conn nr_active_doms) in
	  let active_doms =
	    List.map (D.lookup_by_id conn) active_doms in
	  if not !all then
	    active_doms
	  else (
	    let nr_inactive_doms = C.num_of_defined_domains conn in
	    let inactive_doms =
	      Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
	    let inactive_doms =
	      List.map (D.lookup_by_name conn) inactive_doms in
	    active_doms @ inactive_doms
	  ) in

	(* Get their XML. *)
	let xmls = List.map D.get_xml_desc doms in

	(* Parse the XML. *)
	let xmls = List.map Xml.parse_string xmls in

	(* Return just the XML documents - everything else will be closed
	 * and freed including the connection to the hypervisor.
	 *)
	xmls in

      (* Grr.. Need to use a library which has XPATH support (or cduce). *)
      List.map (
	fun xml ->
	  let nodes, domain_attrs =
	    match xml with
	    | Xml.Element ("domain", attrs, children) -> children, attrs
	    | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in

	  let domid =
	    try Some (int_of_string (List.assoc "id" domain_attrs))
	    with Not_found -> None in

	  let rec loop = function
	    | [] ->
		failwith (s_ "get_xml_desc returned no <name> node in XML")
	    | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
	    | Xml.Element ("name", _, _) :: _ ->
		failwith (s_ "get_xml_desc returned strange <name> node")
	    | _ :: rest -> loop rest
	  in
	  let name = loop nodes in

	  let devices =
	    let devices =
	      List.filter_map (
		function
		| Xml.Element ("devices", _, devices) -> Some devices
		| _ -> None
	      ) nodes in
	    List.concat devices in

	  let rec target_dev_of = function
	    | [] -> None
	    | Xml.Element ("target", attrs, _) :: rest ->
		(try Some (List.assoc "dev" attrs)
		 with Not_found -> target_dev_of rest)
	    | _ :: rest -> target_dev_of rest
	  in

	  let rec source_file_of = function
	    | [] -> None
	    | Xml.Element ("source", attrs, _) :: rest ->
		(try Some (List.assoc "file" attrs)
		 with Not_found -> source_file_of rest)
	    | _ :: rest -> source_file_of rest
	  in

	  let rec source_dev_of = function
	    | [] -> None
	    | Xml.Element ("source", attrs, _) :: rest ->
		(try Some (List.assoc "dev" attrs)
		 with Not_found -> source_dev_of rest)
	    | _ :: rest -> source_dev_of rest
	  in

	  let disks =
	    List.filter_map (
	      function
	      | Xml.Element ("disk", attrs, children) ->
		  let typ =
		    try Some (List.assoc "type" attrs)
		    with Not_found -> None in
		  let device =
		    try Some (List.assoc "device" attrs)
		    with Not_found -> None in
		  let source =
		    match source_file_of children with
		    | (Some _) as source -> source
		    | None -> source_dev_of children in
		  let target = target_dev_of children in

		  (* We only care about devices where we have
		   * source and target.  Ignore CD-ROM devices.
		   *)
		  (match source, target, device with
		   | _, _, Some "cdrom" -> None (* ignore *)
		   | Some source, Some target, Some device ->
		       (* Try to create a 'device' object for this
			* device.  If it fails, print a warning
			* and ignore the device.
			*)
		       (try
			  let dev = new block_device source in
			  Some {
			    d_type = typ; d_device = device;
			    d_source = source; d_target = target;
			    d_dev = dev; d_content = `Unknown
			  }
			with
			  Unix_error (err, func, param) ->
			    eprintf "%s:%s: %s" func param (error_message err);
			    None
		       )
		   | _ -> None (* ignore anything else *)
		  )

	      | _ -> None
	    ) devices in

	  { dom_name = name; dom_id = domid;
	    dom_disks = disks; dom_lv_filesystems = [] }
      ) xmls
    ) else (
      (* In test mode (-t option) the user can pass one or more
       * block devices or filenames (containing partitions/filesystems/etc)
       * which we use for testing virt-df itself.  We create fake domains
       * from these.
       *)
      List.map (
	fun filename ->
	  {
	    dom_name = filename; dom_id = None;
	    dom_disks = [
	      {
		d_type = Some "disk"; d_device = "disk";
		d_source = filename; d_target = "hda";
		d_dev = new block_device filename; d_content = `Unknown;
	      }
	    ];
	    dom_lv_filesystems = []
	  }
      ) !test_files
    ) in

  (* HOF to map over disks. *)
  let map_over_disks doms f =
    List.map (
      fun ({ dom_disks = disks } as dom) ->
	let disks = List.map f disks in
	{ dom with dom_disks = disks }
    ) doms
  in

  (* 'doms' is our list of domains and their guest block devices, and
   * we've successfully opened each block device.  Now probe them
   * to find out what they contain.
   *)
  let doms = map_over_disks doms (
    fun ({ d_dev = dev } as disk) ->
      (* See if it is partitioned first. *)
      let parts = probe_for_partitions dev in
      match parts with
      | Some parts ->
	  { disk with d_content = `Partitions parts }
      | None ->
	  (* Not partitioned.  Does it contain a filesystem? *)
	  let fs = probe_for_filesystem dev in
	  match fs with
	  | Some fs ->
	      { disk with d_content = `Filesystem fs }
	  | None ->
	      (* Not partitioned, no filesystem, is it a PV? *)
	      let pv = probe_for_pv dev in
	      match pv with
	      | Some lvm_name ->
		  { disk with d_content = `PhysicalVolume lvm_name }
	      | None ->
		  disk (* Spare/unknown. *)
  ) in

  (* Now we have either detected partitions or a filesystem on each
   * physical device (or perhaps neither).  See what is on those
   * partitions.
   *)
  let doms = map_over_disks doms (
    function
    | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
	let ps = List.map (
	  fun p ->
	    if p.part_status = Bootable || p.part_status = Nonbootable then (
	      let fs = probe_for_filesystem p.part_dev in
	      match fs with
	      | Some fs ->
		  { p with part_content = `Filesystem fs }
	      | None ->
		  (* Is it a PV? *)
		  let pv = probe_for_pv p.part_dev in
		  match pv with
		  | Some lvm_name ->
		      { p with part_content = `PhysicalVolume lvm_name }
		  | None ->
		      p (* Spare/unknown. *)
	    ) else p
	) parts.parts in
	let parts = { parts with parts = ps } in
	{ disk with d_content = `Partitions parts }
    | disk -> disk
  ) in

  (* LVM filesystem detection
   *
   * For each domain, look for all disks/partitions which have been
   * identified as PVs and pass those back to the respective LVM
   * plugin for LV detection.
   *
   * (Note - a two-stage process because an LV can be spread over
   * several PVs, so we have to detect all PVs belonging to a
   * domain first).
   *
   * XXX To deal with RAID (ie. md devices) we will need to loop
   * around here because RAID is like LVM except that they normally
   * present as block devices which can be used by LVM.
   *)
  (* First: LV detection. *)
  let doms = List.map (
    fun ({ dom_disks = disks } as dom) ->
      (* Find all physical volumes, can be disks or partitions. *)
      let pvs_on_disks = List.filter_map (
	function
	| { d_dev = d_dev;
	    d_content = `PhysicalVolume pv } -> Some (pv, d_dev)
	| _ -> None
      ) disks in
      let pvs_on_partitions = List.map (
	function
	| { d_content = `Partitions { parts = parts } } ->
	    List.filter_map (
	      function
	      | { part_dev = part_dev;
		  part_content = `PhysicalVolume pv } ->
		    Some (pv, part_dev)
	      | _ -> None
	    ) parts
	| _ -> []
      ) disks in
      let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in
      dom, lvs
  ) doms in

  (* Second: filesystem on LV detection. *)
  let doms = List.map (
    fun (dom, lvs) ->
      (* Group the LVs by plug-in type. *)
      let cmp (a,_) (b,_) = compare a b in
      let lvs = List.sort ~cmp lvs in
      let lvs = group_by lvs in

      let lvs =
	List.map (fun (pv, devs) -> list_lvs pv.lvm_plugin_id devs)
	  lvs in
      let lvs = List.concat lvs in

      (* lvs is a list of potential LV devices.  Now run them through the
       * probes to see if any contain filesystems.
       *)
      let filesystems =
	List.filter_map (
	  fun { lv_dev = dev } -> probe_for_filesystem dev
	) lvs in

      { dom with dom_lv_filesystems = filesystems }
  ) doms in

  (* Now print the results.
   *
   * Print the title.
   *)
  let () =
    let total, used, avail =
      match !inodes, !human with
      | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available"
      | false, true -> s_ "Size", s_ "Used", s_ "Available"
      | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in
    printf "%-20s %10s %10s %10s %s\n%!"
      (s_ "Filesystem") total used avail (s_ "Type") in

  let printable_size bytes =
    if bytes < 1024L *^ 1024L then
      sprintf "%Ld bytes" bytes
    else if bytes < 1024L *^ 1024L *^ 1024L then
      sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
    else
      sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
  in

  (* HOF to iterate over filesystems. *)
  let iter_over_filesystems doms
      (f : domain -> ?disk:disk -> ?part:(partition * int) -> filesystem ->
	unit) =
    List.iter (
      fun ({ dom_disks = disks; dom_lv_filesystems = filesystems } as dom) ->
	(* Ordinary filesystems found on disks & partitions. *)
	List.iter (
	  function
	  | ({ d_content = `Filesystem fs } as disk) ->
	      f dom ~disk fs
	  | ({ d_content = `Partitions partitions } as disk) ->
	      List.iteri (
		fun i ->
		  function
		  | ({ part_content = `Filesystem fs } as part) ->
		      f dom ~disk ~part:(part, i) fs
		  | _ -> ()
	      ) partitions.parts
	  | _ -> ()
	) disks;
	(* LV filesystems. *)
	List.iter (fun fs -> f dom fs) filesystems
    ) doms
  in

  (* Print stats for each recognized filesystem. *)
  let print_stats dom ?disk ?part fs =
    (* Printable name is like "domain:hda" or "domain:hda1". *)
    let name =
      let dom_name = dom.dom_name in
      let disk_name =
	match disk with
	| None -> "???" (* XXX keep LV dev around *)
	| Some disk -> disk.d_target
      in
      match part with
      | None ->
	  dom_name ^ ":" ^ disk_name
      | Some (_, pnum) ->
	  dom_name ^ ":" ^ disk_name ^ string_of_int pnum in
    printf "%-20s " name;

    if fs.fs_is_swap then (
      (* Swap partition. *)
      if not !human then
	printf "%10Ld                       %s\n"
	  (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name
      else
	printf "%10s                       %s\n"
	  (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name
    ) else (
      (* Ordinary filesystem. *)
      if not !inodes then (		(* Block display. *)
	(* 'df' doesn't count the restricted blocks. *)
	let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
	let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
	let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in

	if not !human then (		(* Display 1K blocks. *)
	  printf "%10Ld %10Ld %10Ld %s\n"
	    (blocks_total *^ fs.fs_block_size /^ 1024L)
	    (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L)
	    (blocks_avail *^ fs.fs_block_size /^ 1024L)
	    fs.fs_name
	) else (			(* Human-readable blocks. *)
	  printf "%10s %10s %10s %s\n"
	    (printable_size (blocks_total *^ fs.fs_block_size))
	    (printable_size (fs.fs_blocks_used *^ fs.fs_block_size))
	    (printable_size (blocks_avail *^ fs.fs_block_size))
	    fs.fs_name
	)
      ) else (				(* Inodes display. *)
	printf "%10Ld %10Ld %10Ld %s\n"
	  fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail
	  fs.fs_name
      )
    )
  in
  iter_over_filesystems doms print_stats