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 Virt_ctrl_gettext.Gettext
  43 open DBus
  44
  45 let debug = true
  46
  47 let service = "_libvirt._tcp"
  48
  49 let rec print_msg msg =
  50   (match Message.get_type msg with
  51    | Message.Invalid ->
  52        eprintf "Invalid";
  53    | Message.Method_call ->
  54        eprintf "Method_call";
  55    | Message.Method_return ->
  56        eprintf "Method_return";
  57    | Message.Error ->
  58        eprintf "Error";
  59    | Message.Signal ->
  60        eprintf "Signal");
  61
  62   let print_opt f name =
  63     match f msg with
  64     | None -> ()
  65     | Some value -> eprintf "\n\t%s=%S" name value
  66   in
  67   print_opt Message.get_member "member";
  68   print_opt Message.get_path "path";
  69   print_opt Message.get_interface "interface";
  70   print_opt Message.get_sender "sender";
  71
  72   let fields = Message.get msg in
  73   eprintf "\n\t[";
  74   print_fields fields;
  75   eprintf "]\n%!";
  76
  77 and print_fields fields =
  78   eprintf "%s" (String.concat ", " (List.map string_of_ty fields))
  79
  80 (* Perform a synchronous call to an object method. *)
  81 let call_method ~bus ~err ~name ~path ~interface ~methd args =
  82   (* Create the method_call message. *)
  83   let msg = Message.new_method_call name path interface methd in
  84   Message.append msg args;
  85   (* Send the message, get reply. *)
  86   let r = Connection.send_with_reply_and_block bus msg (-1) err in
  87   Message.get r
  88
  89 (* Services we've found.
  90  * This is a map from name -> URI.
  91  * XXX We just assume Xen at the moment.
  92  * XXX The same machine can appear on multiple interfaces, so this
  93  * isn't right.
  94  *)
  95 let services : (string, string) Hashtbl.t = Hashtbl.create 13
  96
  97 (* Process a Found message, indicating that we've found and fully
  98  * resolved a new service.
  99  *)
 100 let add_service bus err msg =
 101   (* match fields in the Found message from ServiceResolver. *)
 102   match Message.get msg with
 103   | Int32 _ ::                          (* interface *)
 104       Int32 (*protocol*)_ ::            (* 0 = IPv4, 1=IPv6 *)
 105       String name ::                    (* "Virtualization Host foo" *)
 106       String _ ::                       (* "_libvirt._tcp" *)
 107       String _ ::                       (* domain name *)
 108       String hostname ::                (* this is the hostname as a string *)
 109       Int32 _ ::                        (* ? aprotocol *)
 110       String address ::                 (* IP address as a string *)
 111       UInt16 (*port*)_ :: _ ->          (* port is set to 0 by libvirtd *)
 112
 113       let hostname = if hostname <> "" then hostname else address in
 114       (*let protocol = if protocol = 1_l then IPv6 else IPv4 in*)
 115
 116       (* XXX *)
 117       let uri = "xen://" ^ hostname ^ "/" in
 118
 119       if debug then eprintf "adding %s %s\n%!" name uri;
 120
 121       Hashtbl.replace services name uri
 122
 123   | _ ->
 124       prerr_endline (s_ "warning: unexpected message contents of Found signal")
 125
 126 (* Process an ItemRemove message, indicating that a service has
 127  * gone away.
 128  *)
 129 let remove_service bus err msg =
 130   (* match fields in the ItemRemove message from ServiceBrowser. *)
 131   match Message.get msg with
 132   | Int32 _ ::                          (* interface *)
 133       Int32 _ ::                        (* protocol *)
 134       String name :: _ ->               (* name *)
 135       if debug then eprintf "removing %s\n%!" name;
 136       Hashtbl.remove services name
 137
 138   | _ ->
 139       prerr_endline
 140         (s_ "warning: unexpected message contents of ItemRemove signal")
 141
 142 (* A service has appeared on the network.  Resolve its IP address, etc. *)
 143 let start_resolve_service bus err sb_path msg =
 144   (* match fields in the ItemNew message from ServiceBrowser. *)
 145   match Message.get msg with
 146   | ((Int32 _) as interface) ::
 147       ((Int32 _) as protocol) ::
 148       ((String _) as name) ::
 149       ((String _) as service) ::
 150       ((String _) as domain) :: _ ->
 151       (* Create a new ServiceResolver object which is used to resolve
 152        * the actual locations of network services found by the ServiceBrowser.
 153        *)
 154       let sr =
 155         call_method ~bus ~err
 156           ~name:"org.freedesktop.Avahi"
 157           ~path:"/"
 158           ~interface:"org.freedesktop.Avahi.Server"
 159           ~methd:"ServiceResolverNew"
 160           [
 161             interface;
 162             protocol;
 163             name;
 164             service;
 165             domain;
 166             Int32 (-1_l);               (* AVAHI_PROTO_UNSPEC *)
 167             UInt32 0_l;                 (* flags *)
 168           ] in
 169       let sr_path =
 170         match sr with
 171         | [ ObjectPath path ] -> path
 172         | _ -> assert false in
 173
 174       if debug then eprintf "ServiceResolver path = %S\n%!" sr_path;
 175
 176       (* Add a match rule so we see these all signals of interest. *)
 177       Bus.add_match bus
 178         (String.concat "," [
 179            "type='signal'";
 180            "sender='org.freedesktop.Avahi.ServiceResolver'";
 181            "path='" ^ sr_path ^ "'";
 182          ]) err;
 183
 184       ()
 185
 186   | _ ->
 187       prerr_endline
 188         (s_ "warning: unexpected message contents of ItemNew signal")
 189
 190 (* This is called when we get a message/signal.  Could be from the
 191  * (global) ServiceBrowser or any of the ServiceResolver objects.
 192  *)
 193 let got_message bus err sb_path msg =
 194   if debug then print_msg msg;
 195
 196   let typ = Message.get_type msg in
 197   let member = match Message.get_member msg with None -> "" | Some m -> m in
 198   let interface =
 199     match Message.get_interface msg with None -> "" | Some m -> m in
 200
 201   if typ = Message.Signal then (
 202     match interface, member with
 203     | "org.freedesktop.Avahi.ServiceBrowser", "CacheExhausted" -> ()
 204     | "org.freedesktop.Avahi.ServiceBrowser", "AllForNow" -> ()
 205     | "org.freedesktop.Avahi.ServiceBrowser", "ItemNew" ->
 206         (* New service has appeared, start to resolve it. *)
 207         start_resolve_service bus err sb_path msg
 208     | "org.freedesktop.Avahi.ServiceResolver", "Found" ->
 209         (* Resolver has finished resolving the name of a previously
 210          * appearing service.
 211          *)
 212         add_service bus err msg
 213     | "org.freedesktop.Avahi.ServiceBrowser", "ItemRemove" ->
 214         (* Service has disappeared. *)
 215         remove_service bus err msg
 216     | "org.freedesktop.DBus", _ -> ()
 217     | interface, member ->
 218         let () =
 219           eprintf (f_ "warning: ignored unknown message %s from %s\n%!")
 220             member interface in
 221         ()
 222   );
 223   true
 224
 225 (* Store the connection ((bus, err, io_id) tuple).  However don't bother
 226  * connecting to D-Bus at all until the user opens the connection
 227  * dialog for the first time.
 228  *)
 229 let connection = ref None
 230
 231 (* Create global error and system bus object, and create the service browser. *)
 232 let connect () =
 233   match !connection with
 234   | Some (bus, err, _) -> (bus, err, false)
 235   | None ->
 236       let err = Error.init () in
 237       let bus = Bus.get Bus.System err in
 238       if Error.is_set err then
 239         failwith (s_ "error set after getting System bus");
 240
 241       (* Create a new ServiceBrowser object which emits a signal whenever
 242        * a new network service of the type specified is found on the network.
 243        *)
 244       let sb =
 245         call_method ~bus ~err
 246           ~name:"org.freedesktop.Avahi"
 247           ~path:"/"
 248           ~interface:"org.freedesktop.Avahi.Server"
 249           ~methd:"ServiceBrowserNew"
 250           [
 251             Int32 (-1_l);               (* interface, -1=AVAHI_IF_UNSPEC *)
 252             Int32 (-1_l);               (* AVAHI_PROTO_UNSPEC *)
 253             String service;             (* service type *)
 254             String "";                  (* XXX call GetDomainName() *)
 255             UInt32 0_l;                 (* flags *)
 256           ] in
 257       let sb_path =
 258         match sb with
 259         | [ ObjectPath path ] -> path
 260         | _ -> assert false in
 261
 262       if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path;
 263
 264       (* Register a callback to accept the signals. *)
 265       (* XXX This leaks memory because it is never freed. *)
 266       Connection.add_filter bus (
 267         fun bus msg -> got_message bus err sb_path msg
 268       );
 269
 270       (* Add a match rule so we see these all signals of interest. *)
 271       Bus.add_match bus
 272         (String.concat "," [
 273            "type='signal'";
 274            "sender='org.freedesktop.Avahi.ServiceBrowser'";
 275            "path='" ^ sb_path ^ "'";
 276          ]) err;
 277
 278       (* This is called from the Gtk main loop whenever there is new
 279        * data to read on the D-Bus socket.
 280        *)
 281       let callback _ =
 282         if debug then eprintf "dbus callback\n%!";
 283         if Connection.read_write_dispatch bus 0 then true
 284         else (                          (* Disconnected. *)
 285           connection := None;
 286           false
 287         )
 288       in
 289
 290       (* Get the file descriptor and attach to the Gtk main loop. *)
 291       let fd = Connection.get_fd bus in
 292       let channel = GMain.Io.channel_of_descr fd in
 293       let io_id = GMain.Io.add_watch ~cond:[`IN] ~callback channel in
 294
 295       connection := Some (bus, err, io_id);
 296       (bus, err, true)
 297
 298 (* This function is called by the connection dialog and is expected
 299  * to return a list of services we know about now.
 300  *)
 301 let find_services () =
 302   let bus, err, just_connected = connect () in
 303
 304   (* If we've just connected, wait briefly for the list to stablise. *)
 305   if just_connected then (
 306     let start_time = Unix.gettimeofday () in
 307     while Unix.gettimeofday () -. start_time < 0.5 do
 308       ignore (Connection.read_write_dispatch bus 500)
 309     done
 310   );
 311
 312   (* Return the services we know about. *)
 313   Hashtbl.fold (fun k v vs -> (k, v) :: vs) services []
 314
 315 ;;
 316
 317 Vc_connection_dlg.find_libvirtd_with_zeroconf := find_services