Add a .gitignore file for git.
[virt-ctrl.git] / 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 = false
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