virt-top/virt_top_xml.ml

   1 (* 'top'-like tool for libvirt domains.
   2  * $Id: virt_top_xml.ml,v 1.1 2007/08/23 09:36:04 rjones Exp $
   3  *
   4  * This file contains all code which requires xml-light.
   5  *)
   6
   7 open ExtList
   8
   9 module C = Libvirt.Connect
  10 module D = Libvirt.Domain
  11 module N = Libvirt.Network ;;
  12
  13 Virt_top.parse_device_xml :=
  14 fun id dom ->
  15   try
  16     let xml = D.get_xml_desc dom in
  17     let xml = Xml.parse_string xml in
  18     let devices =
  19       match xml with
  20       | Xml.Element ("domain", _, children) ->
  21           let devices =
  22             List.filter_map (
  23               function
  24               | Xml.Element ("devices", _, devices) -> Some devices
  25               | _ -> None
  26             ) children in
  27           List.concat devices
  28       | _ ->
  29           failwith "get_xml_desc didn't return <domain/>" in
  30     let rec target_dev_of = function
  31       | [] -> None
  32       | Xml.Element ("target", attrs, _) :: rest ->
  33           (try Some (List.assoc "dev" attrs)
  34            with Not_found -> target_dev_of rest)
  35       | _ :: rest -> target_dev_of rest
  36     in
  37     let blkdevs =
  38       List.filter_map (
  39         function
  40         | Xml.Element ("disk", _, children) -> target_dev_of children
  41         | _ -> None
  42       ) devices in
  43     let netifs =
  44       List.filter_map (
  45         function
  46         | Xml.Element ("interface", _, children) -> target_dev_of children
  47         | _ -> None
  48       ) devices in
  49     blkdevs, netifs
  50   with
  51   | Xml.Error _
  52   | Libvirt.Virterror _ -> [], [] (* ignore transient errs *)