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.
46 let service = "_libvirt._tcp"
48 let rec print_msg msg =
49 (match Message.get_type msg with
52 | Message.Method_call ->
53 eprintf "Method_call";
54 | Message.Method_return ->
55 eprintf "Method_return";
61 let print_opt f name =
64 | Some value -> eprintf "\n\t%s=%S" name value
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";
71 let fields = Message.get msg in
76 and print_fields fields =
77 eprintf "%s" (String.concat ", " (List.map string_of_ty fields))
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
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
94 let services : (string, string) Hashtbl.t = Hashtbl.create 13
96 (* Process a Found message, indicating that we've found and fully
97 * resolved a new service.
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 *)
112 let hostname = if hostname <> "" then hostname else address in
113 (*let protocol = if protocol = 1_l then IPv6 else IPv4 in*)
116 let uri = "xen://" ^ hostname ^ "/" in
118 if debug then eprintf "adding %s %s\n%!" name uri;
120 Hashtbl.replace services name uri
123 prerr_endline "warning: unexpected message contents of Found signal"
125 (* Process an ItemRemove message, indicating that a service has
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
138 prerr_endline "warning: unexpected message contents of ItemRemove signal"
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.
153 call_method ~bus ~err
154 ~name:"org.freedesktop.Avahi"
156 ~interface:"org.freedesktop.Avahi.Server"
157 ~methd:"ServiceResolverNew"
164 Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *)
165 UInt32 0_l; (* flags *)
169 | [ ObjectPath path ] -> path
170 | _ -> assert false in
172 if debug then eprintf "ServiceResolver path = %S\n%!" sr_path;
174 (* Add a match rule so we see these all signals of interest. *)
178 "sender='org.freedesktop.Avahi.ServiceResolver'";
179 "path='" ^ sr_path ^ "'";
185 prerr_endline "warning: unexpected message contents of ItemNew signal"
187 (* This is called when we get a message/signal. Could be from the
188 * (global) ServiceBrowser or any of the ServiceResolver objects.
190 let got_message bus err sb_path msg =
191 if debug then print_msg msg;
193 let typ = Message.get_type msg in
194 let member = match Message.get_member msg with None -> "" | Some m -> m in
196 match Message.get_interface msg with None -> "" | Some m -> m in
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
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%!"
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.
224 let connection = ref None
226 (* Create global error and system bus object, and create the service browser. *)
228 match !connection with
229 | Some (bus, err, _) -> (bus, err, false)
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";
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.
239 call_method ~bus ~err
240 ~name:"org.freedesktop.Avahi"
242 ~interface:"org.freedesktop.Avahi.Server"
243 ~methd:"ServiceBrowserNew"
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 *)
253 | [ ObjectPath path ] -> path
254 | _ -> assert false in
256 if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path;
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
264 (* Add a match rule so we see these all signals of interest. *)
268 "sender='org.freedesktop.Avahi.ServiceBrowser'";
269 "path='" ^ sb_path ^ "'";
272 (* This is called from the Gtk main loop whenever there is new
273 * data to read on the D-Bus socket.
276 if debug then eprintf "dbus callback\n%!";
277 if Connection.read_write_dispatch bus 0 then true
278 else ( (* Disconnected. *)
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
289 connection := Some (bus, err, io_id);
292 (* This function is called by the connection dialog and is expected
293 * to return a list of services we know about now.
295 let find_services () =
296 let bus, err, just_connected = connect () in
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)
306 (* Return the services we know about. *)
307 Hashtbl.fold (fun k v vs -> (k, v) :: vs) services []
311 Vc_connection_dlg.find_libvirtd_with_zeroconf := find_services