1 (* virt-ctrl: A graphical management tool.
2 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
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.
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.
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.
19 This file contains any code which needs optional package OCaml-DBUS.
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/
30 * This code is a complicated state machine because that's what
31 * D-Bus requires. Enable debugging below to trace messages.
33 * It's also very unelegant and leaks memory.
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.
42 open Virt_ctrl_gettext.Gettext
47 let service = "_libvirt._tcp"
49 let rec print_msg msg =
50 (match Message.get_type msg with
53 | Message.Method_call ->
54 eprintf "Method_call";
55 | Message.Method_return ->
56 eprintf "Method_return";
62 let print_opt f name =
65 | Some value -> eprintf "\n\t%s=%S" name value
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";
72 let fields = Message.get msg in
77 and print_fields fields =
78 eprintf "%s" (String.concat ", " (List.map string_of_ty fields))
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
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
95 let services : (string, string) Hashtbl.t = Hashtbl.create 13
97 (* Process a Found message, indicating that we've found and fully
98 * resolved a new service.
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 *)
113 let hostname = if hostname <> "" then hostname else address in
114 (*let protocol = if protocol = 1_l then IPv6 else IPv4 in*)
117 let uri = "xen://" ^ hostname ^ "/" in
119 if debug then eprintf "adding %s %s\n%!" name uri;
121 Hashtbl.replace services name uri
124 prerr_endline (s_ "warning: unexpected message contents of Found signal")
126 (* Process an ItemRemove message, indicating that a service has
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
140 (s_ "warning: unexpected message contents of ItemRemove signal")
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.
155 call_method ~bus ~err
156 ~name:"org.freedesktop.Avahi"
158 ~interface:"org.freedesktop.Avahi.Server"
159 ~methd:"ServiceResolverNew"
166 Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *)
167 UInt32 0_l; (* flags *)
171 | [ ObjectPath path ] -> path
172 | _ -> assert false in
174 if debug then eprintf "ServiceResolver path = %S\n%!" sr_path;
176 (* Add a match rule so we see these all signals of interest. *)
180 "sender='org.freedesktop.Avahi.ServiceResolver'";
181 "path='" ^ sr_path ^ "'";
188 (s_ "warning: unexpected message contents of ItemNew signal")
190 (* This is called when we get a message/signal. Could be from the
191 * (global) ServiceBrowser or any of the ServiceResolver objects.
193 let got_message bus err sb_path msg =
194 if debug then print_msg msg;
196 let typ = Message.get_type msg in
197 let member = match Message.get_member msg with None -> "" | Some m -> m in
199 match Message.get_interface msg with None -> "" | Some m -> m in
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
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 ->
219 eprintf (f_ "warning: ignored unknown message %s from %s\n%!")
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.
229 let connection = ref None
231 (* Create global error and system bus object, and create the service browser. *)
233 match !connection with
234 | Some (bus, err, _) -> (bus, err, false)
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");
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.
245 call_method ~bus ~err
246 ~name:"org.freedesktop.Avahi"
248 ~interface:"org.freedesktop.Avahi.Server"
249 ~methd:"ServiceBrowserNew"
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 *)
259 | [ ObjectPath path ] -> path
260 | _ -> assert false in
262 if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path;
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
270 (* Add a match rule so we see these all signals of interest. *)
274 "sender='org.freedesktop.Avahi.ServiceBrowser'";
275 "path='" ^ sb_path ^ "'";
278 (* This is called from the Gtk main loop whenever there is new
279 * data to read on the D-Bus socket.
282 if debug then eprintf "dbus callback\n%!";
283 if Connection.read_write_dispatch bus 0 then true
284 else ( (* Disconnected. *)
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
295 connection := Some (bus, err, io_id);
298 (* This function is called by the connection dialog and is expected
299 * to return a list of services we know about now.
301 let find_services () =
302 let bus, err, just_connected = connect () in
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)
312 (* Return the services we know about. *)
313 Hashtbl.fold (fun k v vs -> (k, v) :: vs) services []
317 Vc_connection_dlg.find_libvirtd_with_zeroconf := find_services