(* virt-ctrl: A graphical management tool. (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. This file contains any code which needs optional package OCaml-DBUS. *) (* There is *zero* documentation for this. I examined a lot of code * to do this, and the following page was also very helpful: * http://www.amk.ca/diary/2007/04/rough_notes_python_and_dbus.html * See also the DBus API reference: * http://dbus.freedesktop.org/doc/dbus/api/html/index.html * See also Dan Berrange's Perl bindings: * http://search.cpan.org/src/DANBERR/Net-DBus-0.33.5/lib/Net/ * * This code is a complicated state machine because that's what * D-Bus requires. Enable debugging below to trace messages. * * It's also very unelegant and leaks memory. * * The code connects to D-Bus only the first time that the * connection dialog is opened, and thereafter it attaches itself * to the Gtk main loop, waiting for events. It's probably not * safe if the avahi or dbus daemon restarts. *) open Printf open Virt_ctrl_gettext.Gettext open DBus let debug = true let service = "_libvirt._tcp" let rec print_msg msg = (match Message.get_type msg with | Message.Invalid -> eprintf "Invalid"; | Message.Method_call -> eprintf "Method_call"; | Message.Method_return -> eprintf "Method_return"; | Message.Error -> eprintf "Error"; | Message.Signal -> eprintf "Signal"); let print_opt f name = match f msg with | None -> () | Some value -> eprintf "\n\t%s=%S" name value in print_opt Message.get_member "member"; print_opt Message.get_path "path"; print_opt Message.get_interface "interface"; print_opt Message.get_sender "sender"; let fields = Message.get msg in eprintf "\n\t["; print_fields fields; eprintf "]\n%!"; and print_fields fields = eprintf "%s" (String.concat ", " (List.map string_of_ty fields)) (* Perform a synchronous call to an object method. *) let call_method ~bus ~err ~name ~path ~interface ~methd args = (* Create the method_call message. *) let msg = Message.new_method_call name path interface methd in Message.append msg args; (* Send the message, get reply. *) let r = Connection.send_with_reply_and_block bus msg (-1) err in Message.get r (* Services we've found. * This is a map from name -> URI. * XXX We just assume Xen at the moment. * XXX The same machine can appear on multiple interfaces, so this * isn't right. *) let services : (string, string) Hashtbl.t = Hashtbl.create 13 (* Process a Found message, indicating that we've found and fully * resolved a new service. *) let add_service bus err msg = (* match fields in the Found message from ServiceResolver. *) match Message.get msg with | Int32 _ :: (* interface *) Int32 (*protocol*)_ :: (* 0 = IPv4, 1=IPv6 *) String name :: (* "Virtualization Host foo" *) String _ :: (* "_libvirt._tcp" *) String _ :: (* domain name *) String hostname :: (* this is the hostname as a string *) Int32 _ :: (* ? aprotocol *) String address :: (* IP address as a string *) UInt16 (*port*)_ :: _ -> (* port is set to 0 by libvirtd *) let hostname = if hostname <> "" then hostname else address in (*let protocol = if protocol = 1_l then IPv6 else IPv4 in*) (* XXX *) let uri = "xen://" ^ hostname ^ "/" in if debug then eprintf "adding %s %s\n%!" name uri; Hashtbl.replace services name uri | _ -> prerr_endline (s_ "warning: unexpected message contents of Found signal") (* Process an ItemRemove message, indicating that a service has * gone away. *) let remove_service bus err msg = (* match fields in the ItemRemove message from ServiceBrowser. *) match Message.get msg with | Int32 _ :: (* interface *) Int32 _ :: (* protocol *) String name :: _ -> (* name *) if debug then eprintf "removing %s\n%!" name; Hashtbl.remove services name | _ -> prerr_endline (s_ "warning: unexpected message contents of ItemRemove signal") (* A service has appeared on the network. Resolve its IP address, etc. *) let start_resolve_service bus err sb_path msg = (* match fields in the ItemNew message from ServiceBrowser. *) match Message.get msg with | ((Int32 _) as interface) :: ((Int32 _) as protocol) :: ((String _) as name) :: ((String _) as service) :: ((String _) as domain) :: _ -> (* Create a new ServiceResolver object which is used to resolve * the actual locations of network services found by the ServiceBrowser. *) let sr = call_method ~bus ~err ~name:"org.freedesktop.Avahi" ~path:"/" ~interface:"org.freedesktop.Avahi.Server" ~methd:"ServiceResolverNew" [ interface; protocol; name; service; domain; Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *) UInt32 0_l; (* flags *) ] in let sr_path = match sr with | [ ObjectPath path ] -> path | _ -> assert false in if debug then eprintf "ServiceResolver path = %S\n%!" sr_path; (* Add a match rule so we see these all signals of interest. *) Bus.add_match bus (String.concat "," [ "type='signal'"; "sender='org.freedesktop.Avahi.ServiceResolver'"; "path='" ^ sr_path ^ "'"; ]) err; () | _ -> prerr_endline (s_ "warning: unexpected message contents of ItemNew signal") (* This is called when we get a message/signal. Could be from the * (global) ServiceBrowser or any of the ServiceResolver objects. *) let got_message bus err sb_path msg = if debug then print_msg msg; let typ = Message.get_type msg in let member = match Message.get_member msg with None -> "" | Some m -> m in let interface = match Message.get_interface msg with None -> "" | Some m -> m in if typ = Message.Signal then ( match interface, member with | "org.freedesktop.Avahi.ServiceBrowser", "CacheExhausted" -> () | "org.freedesktop.Avahi.ServiceBrowser", "AllForNow" -> () | "org.freedesktop.Avahi.ServiceBrowser", "ItemNew" -> (* New service has appeared, start to resolve it. *) start_resolve_service bus err sb_path msg | "org.freedesktop.Avahi.ServiceResolver", "Found" -> (* Resolver has finished resolving the name of a previously * appearing service. *) add_service bus err msg | "org.freedesktop.Avahi.ServiceBrowser", "ItemRemove" -> (* Service has disappeared. *) remove_service bus err msg | "org.freedesktop.DBus", _ -> () | interface, member -> let () = eprintf (f_ "warning: ignored unknown message %s from %s\n%!") member interface in () ); true (* Store the connection ((bus, err, io_id) tuple). However don't bother * connecting to D-Bus at all until the user opens the connection * dialog for the first time. *) let connection = ref None (* Create global error and system bus object, and create the service browser. *) let connect () = match !connection with | Some (bus, err, _) -> (bus, err, false) | None -> let err = Error.init () in let bus = Bus.get Bus.System err in if Error.is_set err then failwith (s_ "error set after getting System bus"); (* Create a new ServiceBrowser object which emits a signal whenever * a new network service of the type specified is found on the network. *) let sb = call_method ~bus ~err ~name:"org.freedesktop.Avahi" ~path:"/" ~interface:"org.freedesktop.Avahi.Server" ~methd:"ServiceBrowserNew" [ Int32 (-1_l); (* interface, -1=AVAHI_IF_UNSPEC *) Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *) String service; (* service type *) String ""; (* XXX call GetDomainName() *) UInt32 0_l; (* flags *) ] in let sb_path = match sb with | [ ObjectPath path ] -> path | _ -> assert false in if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path; (* Register a callback to accept the signals. *) (* XXX This leaks memory because it is never freed. *) Connection.add_filter bus ( fun bus msg -> got_message bus err sb_path msg ); (* Add a match rule so we see these all signals of interest. *) Bus.add_match bus (String.concat "," [ "type='signal'"; "sender='org.freedesktop.Avahi.ServiceBrowser'"; "path='" ^ sb_path ^ "'"; ]) err; (* This is called from the Gtk main loop whenever there is new * data to read on the D-Bus socket. *) let callback _ = if debug then eprintf "dbus callback\n%!"; if Connection.read_write_dispatch bus 0 then true else ( (* Disconnected. *) connection := None; false ) in (* Get the file descriptor and attach to the Gtk main loop. *) let fd = Connection.get_fd bus in let channel = GMain.Io.channel_of_descr fd in let io_id = GMain.Io.add_watch ~cond:[`IN] ~callback channel in connection := Some (bus, err, io_id); (bus, err, true) (* This function is called by the connection dialog and is expected * to return a list of services we know about now. *) let find_services () = let bus, err, just_connected = connect () in (* If we've just connected, wait briefly for the list to stablise. *) if just_connected then ( let start_time = Unix.gettimeofday () in while Unix.gettimeofday () -. start_time < 0.5 do ignore (Connection.read_write_dispatch bus 500) done ); (* Return the services we know about. *) Hashtbl.fold (fun k v vs -> (k, v) :: vs) services [] ;; Vc_connection_dlg.find_libvirtd_with_zeroconf := find_services