X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=virt-ctrl%2Fvc_dbus.ml;h=82b66dded04c5a9303d367b430b6edbb4c3511b5;hb=b9320ec4678a8a7bb88a8b8aa72805b79ce48daf;hp=511748264cd0ac49f60633a806f3ff81aeb935ff;hpb=8a2211eb0976db33a6795ee9933bd7e7400c933c;p=virt-top.git diff --git a/virt-ctrl/vc_dbus.ml b/virt-ctrl/vc_dbus.ml index 5117482..82b66dd 100644 --- a/virt-ctrl/vc_dbus.ml +++ b/virt-ctrl/vc_dbus.ml @@ -19,3 +19,299 @@ 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