virt-ctrl/vc_dbus.ml

   1 (* virt-ctrl: A graphical management tool.
   2    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18
  19    This file contains any code which needs optional package OCaml-DBUS.
  20 *)
  21
  22 (* There is *zero* documentation for this.  I examined a lot of code
  23  * to do this, and the following page was also very helpful:
  24  * http://www.amk.ca/diary/2007/04/rough_notes_python_and_dbus.html
  25  * See also the DBus API reference:
  26  * http://dbus.freedesktop.org/doc/dbus/api/html/index.html
  27  * See also Dan Berrange's Perl bindings:
  28  * http://search.cpan.org/src/DANBERR/Net-DBus-0.33.5/lib/Net/
  29  *
  30  * This code is a complicated state machine because that's what
  31  * D-Bus requires.  Enable debugging below to trace messages.
  32  *
  33  * It's also very unelegant and leaks memory.
  34  *
  35  * The code connects to D-Bus only the first time that the
  36  * connection dialog is opened, and thereafter it attaches itself
  37  * to the Gtk main loop, waiting for events.  It's probably not
  38  * safe if the avahi or dbus daemon restarts.
  39  *)
  40
  41 open Printf
  42 open DBus
  43
  44 let debug = true
  45
  46 let service = "_libvirt._tcp"
  47
  48 let rec print_msg msg =
  49   (match Message.get_type msg with
  50    | Message.Invalid ->
  51        eprintf "Invalid";
  52    | Message.Method_call ->
  53        eprintf "Method_call";
  54    | Message.Method_return ->
  55        eprintf "Method_return";
  56    | Message.Error ->
  57        eprintf "Error";
  58    | Message.Signal ->
  59        eprintf "Signal");
  60
  61   let print_opt f name =
  62     match f msg with
  63     | None -> ()
  64     | Some value -> eprintf "\n\t%s=%S" name value
  65   in
  66   print_opt Message.get_member "member";
  67   print_opt Message.get_path "path";
  68   print_opt Message.get_interface "interface";
  69   print_opt Message.get_sender "sender";
  70
  71   let fields = Message.get msg in
  72   eprintf "\n\t[";
  73   print_fields fields;
  74   eprintf "]\n%!";
  75
  76 and print_fields fields =
  77   eprintf "%s" (String.concat ", " (List.map string_of_ty fields))
  78
  79 (* Perform a synchronous call to an object method. *)
  80 let call_method ~bus ~err ~name ~path ~interface ~methd args =
  81   (* Create the method_call message. *)
  82   let msg = Message.new_method_call name path interface methd in
  83   Message.append msg args;
  84   (* Send the message, get reply. *)
  85   let r = Connection.send_with_reply_and_block bus msg (-1) err in
  86   Message.get r
  87
  88 (* Services we've found.
  89  * This is a map from name -> URI.
  90  * XXX We just assume Xen at the moment.
  91  * XXX The same machine can appear on multiple interfaces, so this
  92  * isn't right.
  93  *)
  94 let services : (string, string) Hashtbl.t = Hashtbl.create 13
  95
  96 (* Process a Found message, indicating that we've found and fully
  97  * resolved a new service.
  98  *)
  99 let add_service bus err msg =
 100   (* match fields in the Found message from ServiceResolver. *)
 101   match Message.get msg with
 102   | Int32 _ ::                          (* interface *)
 103       Int32 (*protocol*)_ ::            (* 0 = IPv4, 1=IPv6 *)
 104       String name ::                    (* "Virtualization Host foo" *)
 105       String _ ::                       (* "_libvirt._tcp" *)
 106       String _ ::                       (* domain name *)
 107       String hostname ::                (* this is the hostname as a string *)
 108       Int32 _ ::                        (* ? aprotocol *)
 109       String address ::                 (* IP address as a string *)
 110       UInt16 (*port*)_ :: _ ->          (* port is set to 0 by libvirtd *)
 111
 112       let hostname = if hostname <> "" then hostname else address in
 113       (*let protocol = if protocol = 1_l then IPv6 else IPv4 in*)
 114
 115       (* XXX *)
 116       let uri = "xen://" ^ hostname ^ "/" in
 117
 118       if debug then eprintf "adding %s %s\n%!" name uri;
 119
 120       Hashtbl.replace services name uri
 121
 122   | _ ->
 123       prerr_endline "warning: unexpected message contents of Found signal"
 124
 125 (* Process an ItemRemove message, indicating that a service has
 126  * gone away.
 127  *)
 128 let remove_service bus err msg =
 129   (* match fields in the ItemRemove message from ServiceBrowser. *)
 130   match Message.get msg with
 131   | Int32 _ ::                          (* interface *)
 132       Int32 _ ::                        (* protocol *)
 133       String name :: _ ->               (* name *)
 134       if debug then eprintf "removing %s\n%!" name;
 135       Hashtbl.remove services name
 136
 137   | _ ->
 138       prerr_endline "warning: unexpected message contents of ItemRemove signal"
 139
 140 (* A service has appeared on the network.  Resolve its IP address, etc. *)
 141 let start_resolve_service bus err sb_path msg =
 142   (* match fields in the ItemNew message from ServiceBrowser. *)
 143   match Message.get msg with
 144   | ((Int32 _) as interface) ::
 145       ((Int32 _) as protocol) ::
 146       ((String _) as name) ::
 147       ((String _) as service) ::
 148       ((String _) as domain) :: _ ->
 149       (* Create a new ServiceResolver object which is used to resolve
 150        * the actual locations of network services found by the ServiceBrowser.
 151        *)
 152       let sr =
 153         call_method ~bus ~err
 154           ~name:"org.freedesktop.Avahi"
 155           ~path:"/"
 156           ~interface:"org.freedesktop.Avahi.Server"
 157           ~methd:"ServiceResolverNew"
 158           [
 159             interface;
 160             protocol;
 161             name;
 162             service;
 163             domain;
 164             Int32 (-1_l);               (* AVAHI_PROTO_UNSPEC *)
 165             UInt32 0_l;                 (* flags *)
 166           ] in
 167       let sr_path =
 168         match sr with
 169         | [ ObjectPath path ] -> path
 170         | _ -> assert false in
 171
 172       if debug then eprintf "ServiceResolver path = %S\n%!" sr_path;
 173
 174       (* Add a match rule so we see these all signals of interest. *)
 175       Bus.add_match bus
 176         (String.concat "," [
 177            "type='signal'";
 178            "sender='org.freedesktop.Avahi.ServiceResolver'";
 179            "path='" ^ sr_path ^ "'";
 180          ]) err;
 181
 182       ()
 183
 184   | _ ->
 185       prerr_endline "warning: unexpected message contents of ItemNew signal"
 186
 187 (* This is called when we get a message/signal.  Could be from the
 188  * (global) ServiceBrowser or any of the ServiceResolver objects.
 189  *)
 190 let got_message bus err sb_path msg =
 191   if debug then print_msg msg;
 192
 193   let typ = Message.get_type msg in
 194   let member = match Message.get_member msg with None -> "" | Some m -> m in
 195   let interface =
 196     match Message.get_interface msg with None -> "" | Some m -> m in
 197
 198   if typ = Message.Signal then (
 199     match interface, member with
 200     | "org.freedesktop.Avahi.ServiceBrowser", "CacheExhausted" -> ()
 201     | "org.freedesktop.Avahi.ServiceBrowser", "AllForNow" -> ()
 202     | "org.freedesktop.Avahi.ServiceBrowser", "ItemNew" ->
 203         (* New service has appeared, start to resolve it. *)
 204         start_resolve_service bus err sb_path msg
 205     | "org.freedesktop.Avahi.ServiceResolver", "Found" ->
 206         (* Resolver has finished resolving the name of a previously
 207          * appearing service.
 208          *)
 209         add_service bus err msg
 210     | "org.freedesktop.Avahi.ServiceBrowser", "ItemRemove" ->
 211         (* Service has disappeared. *)
 212         remove_service bus err msg
 213     | "org.freedesktop.DBus", _ -> ()
 214     | interface, member ->
 215         eprintf "warning: ignored unknown message %s from %s\n%!"
 216           member interface
 217   );
 218   true
 219
 220 (* Store the connection ((bus, err, io_id) tuple).  However don't bother
 221  * connecting to D-Bus at all until the user opens the connection
 222  * dialog for the first time.
 223  *)
 224 let connection = ref None
 225
 226 (* Create global error and system bus object, and create the service browser. *)
 227 let connect () =
 228   match !connection with
 229   | Some (bus, err, _) -> (bus, err, false)
 230   | None ->
 231       let err = Error.init () in
 232       let bus = Bus.get Bus.System err in
 233       if Error.is_set err then failwith "error set after getting System bus";
 234
 235       (* Create a new ServiceBrowser object which emits a signal whenever
 236        * a new network service of the type specified is found on the network.
 237        *)
 238       let sb =
 239         call_method ~bus ~err
 240           ~name:"org.freedesktop.Avahi"
 241           ~path:"/"
 242           ~interface:"org.freedesktop.Avahi.Server"
 243           ~methd:"ServiceBrowserNew"
 244           [
 245             Int32 (-1_l);               (* interface, -1=AVAHI_IF_UNSPEC *)
 246             Int32 (-1_l);               (* AVAHI_PROTO_UNSPEC *)
 247             String service;             (* service type *)
 248             String "";                  (* XXX call GetDomainName() *)
 249             UInt32 0_l;                 (* flags *)
 250           ] in
 251       let sb_path =
 252         match sb with
 253         | [ ObjectPath path ] -> path
 254         | _ -> assert false in
 255
 256       if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path;
 257
 258       (* Register a callback to accept the signals. *)
 259       (* XXX This leaks memory because it is never freed. *)
 260       Connection.add_filter bus (
 261         fun bus msg -> got_message bus err sb_path msg
 262       );
 263
 264       (* Add a match rule so we see these all signals of interest. *)
 265       Bus.add_match bus
 266         (String.concat "," [
 267            "type='signal'";
 268            "sender='org.freedesktop.Avahi.ServiceBrowser'";
 269            "path='" ^ sb_path ^ "'";
 270          ]) err;
 271
 272       (* This is called from the Gtk main loop whenever there is new
 273        * data to read on the D-Bus socket.
 274        *)
 275       let callback _ =
 276         if debug then eprintf "dbus callback\n%!";
 277         if Connection.read_write_dispatch bus 0 then true
 278         else (                          (* Disconnected. *)
 279           connection := None;
 280           false
 281         )
 282       in
 283
 284       (* Get the file descriptor and attach to the Gtk main loop. *)
 285       let fd = Connection.get_fd bus in
 286       let channel = GMain.Io.channel_of_descr fd in
 287       let io_id = GMain.Io.add_watch ~cond:[`IN] ~callback channel in
 288
 289       connection := Some (bus, err, io_id);
 290       (bus, err, true)
 291
 292 (* This function is called by the connection dialog and is expected
 293  * to return a list of services we know about now.
 294  *)
 295 let find_services () =
 296   let bus, err, just_connected = connect () in
 297
 298   (* If we've just connected, wait briefly for the list to stablise. *)
 299   if just_connected then (
 300     let start_time = Unix.gettimeofday () in
 301     while Unix.gettimeofday () -. start_time < 0.5 do
 302       ignore (Connection.read_write_dispatch bus 500)
 303     done
 304   );
 305
 306   (* Return the services we know about. *)
 307   Hashtbl.fold (fun k v vs -> (k, v) :: vs) services []
 308
 309 ;;
 310
 311 Vc_connection_dlg.find_libvirtd_with_zeroconf := find_services