diff options
Diffstat (limited to 'virt-ctrl/vc_dbus.ml')
| -rw-r--r-- | virt-ctrl/vc_dbus.ml | 317 |
1 files changed, 0 insertions, 317 deletions
diff --git a/virt-ctrl/vc_dbus.ml b/virt-ctrl/vc_dbus.ml deleted file mode 100644 index 82b66dd..0000000 --- a/virt-ctrl/vc_dbus.ml +++ /dev/null @@ -1,317 +0,0 @@ -(* 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 |