(* '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

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

open Int63.Operators

open Virt_df_gettext.Gettext
open Virt_df

let disk_block_size = ~^512

(* A libvirt-backed block device. *)
class libvirt_device dom name path blocksize =
  (* Size is never really used. *)
  let size = ~^0 in
object (self)
  inherit Diskimage.device
  method read offset len =
    let offset = Int63.to_int64 offset in
    let len = Int63.to_int len in
    let str = String.make len '\000' in
    ignore (D.block_peek dom path offset len str 0);
    str
  method size = size
  method name = name
  method blocksize = blocksize
  method map_block _ = []
  method contiguous offset = size -^ offset
  method close () = ()
  initializer
    (* Check that access is possible - throws a virterror if not. *)
    D.block_peek dom path 0L 0 "" 0
end

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

  let version () =
    printf "virt-df %s\n" Virt_df_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";
    "--connect", Arg.String set_uri,
      "uri " ^ s_ "Connect to URI";
    "--csv", Arg.Set csv_mode,
      " " ^ s_ "Write results in CSV format";
    "--debug", Arg.Set Diskimage.debug,
      " " ^ s_ "Debug mode (default: false)";
    "-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;

  (* Set up CSV support. *)
  let csv_write =
    if not !csv_mode then
      fun _ -> assert false (* Should never happen. *)
    else
      match !csv_write with
      | None ->
	  prerr_endline (s_ "CSV is not supported in this build of virt-df");
	  exit 1
      | Some csv_write ->
	  csv_write stdout
  in

  let doms =
    if !test_files = [] then (
      let xmls =
	(* Connect to the hypervisor. *)
	let conn =
	  let name = !uri in
	  try C.connect ?name ()
	  with
	    Libvirt.Virterror err ->
	      prerr_endline (Libvirt.Virterror.to_string err);
	      (* If non-root and no explicit connection URI, print a warning. *)
	      if Unix.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

	let xmls =
	  try
	    (* 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 (fun dom -> dom, D.get_xml_desc dom) doms in

	    (* Parse the XML. *)
	    let xmls = List.map (fun (dom, xml) ->
				   dom, Xml.parse_string xml) xmls in

	    xmls
	  with
	    Libvirt.Virterror err ->
	      prerr_endline (Libvirt.Virterror.to_string err);
	      exit 1 in
	xmls in

      (* Grr.. Need to use a library which has XPATH support (or cduce). *)
      List.map (
	fun (dom, 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 CD-ROMs *)
		   | Some source, Some target, _ -> Some (target, source)
		   | _ -> None (* ignore anything else *)
		  )

	      | _ -> None
	    ) devices in

	  let disks = List.filter_map (
	    fun (name, path) ->
	      try Some (name, new libvirt_device dom name path disk_block_size)
	      with Libvirt.Virterror err ->
		eprintf "%s: %s\n" name (Libvirt.Virterror.to_string err);
		None
	  ) disks in

	  name, disks
      ) 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.filter_map (
	fun filename ->
	  try Some (filename,
		    ["hda",
		     new Diskimage.block_device filename disk_block_size])
	  with Unix.Unix_error (err, func, param) ->
	    eprintf "%s:%s: %s\n" func param (Unix.error_message err);
	    None
      ) !test_files
    ) in

  (* Convert these to Diskimage library 'machine's. *)
  let machines = List.map (
    fun (name, disks) -> Diskimage.open_machine_from_devices name disks
  ) doms in

  (* Scan them. *)
  let machines = List.map Diskimage.scan_machine machines 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
    if not !csv_mode then
      printf "%-32s %10s %10s %10s %s\n%!"
	(s_ "Filesystem") total used avail (s_ "Type")
    else
      csv_write [ "Filesystem"; total; used; avail; "Type" ] in

  let printable_size bytes =
    if bytes < ~^1024 *^ ~^1024 then
      sprintf "%s bytes" (Int63.to_string bytes)
    else if bytes < ~^1024 *^ ~^1024 *^ ~^1024 then
      sprintf "%.1f MiB" (Int63.to_float (bytes /^ ~^1024) /. 1024.)
    else
      sprintf "%.1f GiB" (Int63.to_float (bytes /^ ~^1024 /^ ~^1024) /. 1024.)
  in

  (* HOF to iterate over filesystems. *)
  let iter_over_filesystems machines
      (f : Diskimage.machine -> ?disk:Diskimage.disk -> ?partno:int ->
	Diskimage.device -> Diskimage.filesystem ->
	unit) =
    List.iter (
      fun ({ Diskimage.m_disks = disks;
	     m_lv_filesystems = filesystems } as dom) ->
	(* Ordinary filesystems found on disks & partitions. *)
	List.iter (
	  function
	  | ({ Diskimage.d_content = `Filesystem fs; d_dev = dev } as disk) ->
	      f dom ~disk (dev :> Diskimage.device) fs
	  | ({ Diskimage.d_content = `Partitions partitions } as disk) ->
	      List.iteri (
		fun i ->
		  function
		  | { Diskimage.part_content = `Filesystem fs;
		      part_dev = dev } ->
		      f dom ~disk ~partno:(i+1) dev fs
		  | _ -> ()
	      ) partitions.Diskimage.parts
	  | _ -> ()
	) disks;
	(* LV filesystems. *)
	List.iter (
	  fun ({Diskimage.lv_dev = dev}, fs) -> f dom dev fs
	) filesystems
    ) machines
  in

  (* Printable name is like "domain:hda" or "domain:hda1". *)
  let printable_name machine ?disk ?partno dev =
    let m_name = machine.Diskimage.m_name in
    (* Get the disk name (eg. "hda") from the domain XML, if
     * we have it, otherwise use the device name (eg. for LVM).
     *)
    let disk_name =
      match disk with
      | None -> dev#name
      | Some disk -> disk.Diskimage.d_name
    in
    match partno with
    | None ->
	m_name ^ ":" ^ disk_name
    | Some partno ->
	m_name ^ ":" ^ disk_name ^ string_of_int partno
  in

  (* Print stats for each recognized filesystem. *)
  let print_stats machine ?disk ?partno dev fs =
    let name = printable_name machine ?disk ?partno dev in
    printf "%-32s " name;

    let {
      Diskimage.fs_blocksize = fs_blocksize;
      fs_blocks_total = fs_blocks_total;
      fs_is_swap = fs_is_swap;
      fs_blocks_reserved = fs_blocks_reserved;
      fs_blocks_avail = fs_blocks_avail;
      fs_blocks_used = fs_blocks_used;
      fs_inodes_total = fs_inodes_total;
      fs_inodes_reserved = fs_inodes_reserved;
      fs_inodes_avail = fs_inodes_avail;
      fs_inodes_used = fs_inodes_used
    } = fs in

    let fs_name = Diskimage.name_of_filesystem fs in

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

	if not !human then (		(* Display 1K blocks. *)
	  printf "%10s %10s %10s %s\n"
	    (Int63.to_string (blocks_total *^ fs_blocksize /^ ~^1024))
	    (Int63.to_string (fs_blocks_used *^ fs_blocksize /^ ~^1024))
	    (Int63.to_string (blocks_avail *^ fs_blocksize /^ ~^1024))
	    fs_name
	) else (			(* Human-readable blocks. *)
	  printf "%10s %10s %10s %s\n"
	    (printable_size (blocks_total *^ fs_blocksize))
	    (printable_size (fs_blocks_used *^ fs_blocksize))
	    (printable_size (blocks_avail *^ fs_blocksize))
	    fs_name
	)
      ) else (				(* Inodes display. *)
	printf "%10s %10s %10s %s\n"
	  (Int63.to_string fs_inodes_total)
	  (Int63.to_string fs_inodes_used)
	  (Int63.to_string fs_inodes_avail)
	  fs_name
      )
    )
  in

  (* Alternate version of print_stats which writes to a CSV file.
   * We ignore the human-readable option because we assume that
   * the data will be post-processed by something.
   *)
  let print_stats_csv machine ?disk ?partno dev fs =
    let name = printable_name machine ?disk ?partno dev in

    let {
      Diskimage.fs_blocksize = fs_blocksize;
      fs_blocks_total = fs_blocks_total;
      fs_is_swap = fs_is_swap;
      fs_blocks_reserved = fs_blocks_reserved;
      fs_blocks_avail = fs_blocks_avail;
      fs_blocks_used = fs_blocks_used;
      fs_inodes_total = fs_inodes_total;
      fs_inodes_reserved = fs_inodes_reserved;
      fs_inodes_avail = fs_inodes_avail;
      fs_inodes_used = fs_inodes_used
    } = fs in

    let fs_name = Diskimage.name_of_filesystem fs in

    let row =
      if fs_is_swap then
	(* Swap partition. *)
	[ Int63.to_string (fs_blocksize *^ fs_blocks_total /^ ~^1024);
	  ""; "" ]
      else (
	(* Ordinary filesystem. *)
	if not !inodes then (		(* 1K block display. *)
	  (* 'df' doesn't count the restricted blocks. *)
	  let blocks_total = fs_blocks_total -^ fs_blocks_reserved in
	  let blocks_avail = fs_blocks_avail -^ fs_blocks_reserved in
	  let blocks_avail = if blocks_avail < ~^0 then ~^0 else blocks_avail in

	  [ Int63.to_string (blocks_total *^ fs_blocksize /^ ~^1024);
	    Int63.to_string (fs_blocks_used *^ fs_blocksize /^ ~^1024);
	    Int63.to_string (blocks_avail *^ fs_blocksize /^ ~^1024) ]
	) else (			(* Inodes display. *)
	  [ Int63.to_string fs_inodes_total;
	    Int63.to_string fs_inodes_used;
	    Int63.to_string fs_inodes_avail ]
	)
      ) in

    let row = name :: row @ [fs_name] in
    csv_write row
  in

  iter_over_filesystems machines
    (if not !csv_mode then print_stats else print_stats_csv)