virt-df/virt_df.ml

   1 (* 'df' command for virtual domains.
   2  * $Id$
   3  *)
   4
   5 open Printf
   6 open ExtList
   7
   8 module C = Libvirt.Connect
   9 module D = Libvirt.Domain
  10 module N = Libvirt.Network
  11
  12 let uri = ref None
  13
  14 let () =
  15   (* Command line argument parsing. *)
  16   let set_uri = function "" -> uri := None | u -> uri := Some u in
  17
  18   let argspec = Arg.align [
  19     "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)";
  20     "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)";
  21   ] in
  22
  23   let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in
  24   let usage_msg = "virt-df : like 'df', shows disk space used in guests
  25
  26 SUMMARY
  27   virt-df [-options]
  28
  29 OPTIONS" in
  30
  31   Arg.parse argspec anon_fun usage_msg
  32
  33 let xmls =
  34   (* Connect to the hypervisor. *)
  35   let conn =
  36     let name = !uri in
  37     try C.connect_readonly ?name ()
  38     with
  39       Libvirt.Virterror err ->
  40         prerr_endline (Libvirt.Virterror.to_string err);
  41         (* If non-root and no explicit connection URI, print a warning. *)
  42         if Unix.geteuid () <> 0 && name = None then (
  43           print_endline "NB: If you want to monitor a local Xen hypervisor, you usually need to be root";
  44         );
  45         exit 1 in
  46
  47   (* Get the list of active & inactive domains. *)
  48   let doms =
  49     let nr_active_doms = C.num_of_domains conn in
  50     let active_doms = Array.to_list (C.list_domains conn nr_active_doms) in
  51     let active_doms = List.map (D.lookup_by_id conn) active_doms in
  52     let nr_inactive_doms = C.num_of_defined_domains conn in
  53     let inactive_doms =
  54       Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
  55     let inactive_doms = List.map (D.lookup_by_name conn) inactive_doms in
  56     active_doms @ inactive_doms in
  57
  58   (* Get their XML. *)
  59   let xmls = List.map D.get_xml_desc doms in
  60
  61   (* Parse the XML. *)
  62   let xmls = List.map Xml.parse_string xmls in
  63
  64   (* Return just the XML documents - everything else will be closed
  65    * and freed including the connection to the hypervisor.
  66    *)
  67   xmls
  68
  69 (* Parse out the device XML to get the names of disks. *)
  70 type domain = {
  71   dom_name : string;                    (* Domain name. *)
  72   dom_id : int option;                  (* Domain ID (if running). *)
  73   dom_disks : disk list;                (* Domain disks. *)
  74 }
  75 and disk = {
  76   d_type : string option;               (* The <disk type=...> *)
  77   d_device : string option;             (* The <disk device=...> *)
  78   d_file : string option;               (* The <source file=...> *)
  79   d_dev : string option;                (* The <target dev=...> *)
  80 }
  81
  82 let doms : domain list =
  83   (* Grr.. Need to use a library which has XPATH support (or cduce). *)
  84   List.map (
  85     fun xml ->
  86       let nodes, domain_attrs =
  87         match xml with
  88         | Xml.Element ("domain", attrs, children) -> children, attrs
  89         | _ -> failwith "get_xml_desc didn't return <domain/>" in
  90
  91       let domid =
  92         try Some (int_of_string (List.assoc "id" domain_attrs))
  93         with Not_found -> None in
  94
  95       let rec loop = function
  96         | [] ->
  97             failwith "get_xml_desc returned no <name> node in XML"
  98         | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
  99         | Xml.Element ("name", _, _) :: _ ->
 100             failwith "get_xml_desc returned strange <name> node"
 101         | _ :: rest -> loop rest
 102       in
 103       let name = loop nodes in
 104
 105       let devices =
 106         let devices =
 107           List.filter_map (
 108             function
 109             | Xml.Element ("devices", _, devices) -> Some devices
 110             | _ -> None
 111           ) nodes in
 112         List.concat devices in
 113
 114       let rec target_dev_of = function
 115         | [] -> None
 116         | Xml.Element ("target", attrs, _) :: rest ->
 117             (try Some (List.assoc "dev" attrs)
 118              with Not_found -> target_dev_of rest)
 119         | _ :: rest -> target_dev_of rest
 120       in
 121
 122       let rec source_file_of = function
 123         | [] -> None
 124         | Xml.Element ("source", attrs, _) :: rest ->
 125             (try Some (List.assoc "file" attrs)
 126              with Not_found -> source_file_of rest)
 127         | _ :: rest -> source_file_of rest
 128       in
 129
 130       let disks =
 131         List.filter_map (
 132           function
 133           | Xml.Element ("disk", attrs, children) ->
 134               let typ =
 135                 try Some (List.assoc "type" attrs)
 136                 with Not_found -> None in
 137               let device =
 138                 try Some (List.assoc "device" attrs)
 139                 with Not_found -> None in
 140               let file = source_file_of children in
 141               let dev = target_dev_of children in
 142
 143               Some {
 144                 d_type = typ; d_device = device; d_file = file; d_dev = dev
 145               }
 146           | _ -> None
 147         ) devices in
 148
 149       { dom_name = name; dom_id = domid; dom_disks = disks }
 150   ) xmls
 151
 152 (* Print the domains / devices. *)
 153 let () =
 154   List.iter (
 155     fun { dom_name = dom_name; dom_disks = dom_disks } ->
 156       printf "%s:\n" dom_name;
 157       List.iter (
 158         function
 159         | { d_file = Some file; d_dev = Some dev } ->
 160             printf "\t%s -> %s\n" file dev
 161         | _ ->
 162             printf "\t(device omitted, missing <source> or <target> in XML\n";
 163       ) dom_disks
 164   ) doms