virt-top/virt_top_xml.ml

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