From d618fcccebbd21b497dc872b94548a919a5ff27f Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Thu, 1 Jan 1970 00:00:00 +0000 Subject: [PATCH] New connection dialog with support for Avahi detection of libvirtd. --- virt-ctrl/vc_connection_dlg.ml | 185 ++++++++++++++++++++++++- virt-ctrl/vc_connection_dlg.mli | 22 ++- virt-ctrl/vc_dbus.ml | 290 ++++++++++++++++++++++++++++++++++++++++ virt-ctrl/vc_dbus.mli | 22 +++ 4 files changed, 511 insertions(+), 8 deletions(-) create mode 100644 virt-ctrl/vc_dbus.mli diff --git a/virt-ctrl/vc_connection_dlg.ml b/virt-ctrl/vc_connection_dlg.ml index 9ba95a7..9575efc 100644 --- a/virt-ctrl/vc_connection_dlg.ml +++ b/virt-ctrl/vc_connection_dlg.ml @@ -17,13 +17,184 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -(* Open connection dialog. - * This should be a lot more sophisticated. XXX - *) -let open_connection () = +type name = string +type uri = string +type service = name * uri + +let local_xen_uri = "xen:///" +let local_qemu_uri = "qemu:///system" + +(* Code in Vc_dbus overrides this, if that capability was compiled in. *) +let find_libvirtd_with_zeroconf = ref (fun () -> []) + +(* Code in Vc_icons may override these with icons. *) +let icon_16x16_devices_computer_png = ref None +let icon_24x24_devices_computer_png = ref None +let icon_32x32_devices_computer_png = ref None +let icon_48x48_devices_computer_png = ref None + +(* Open connection dialog. *) +let open_connection parent () = let title = "Open connection to hypervisor" in - let uri = - GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in - match uri with + let position = `CENTER_ON_PARENT in + + let dlg = GWindow.dialog ~title ~position ~parent + ~modal:true ~width:450 () in + + (* We will enter the Gtk main loop recursively. Wire up close and + * other buttons to quit the recursive main loop. + *) + ignore (dlg#connect#destroy ~callback:GMain.quit); + ignore (dlg#event#connect#delete + ~callback:(fun _ -> GMain.quit (); false)); + + let uri = ref None in + + (* Pack the buttons into the dialog. *) + let vbox = dlg#vbox in + vbox#set_spacing 5; + + (* Local connections. *) + let () = + let frame = + GBin.frame ~label:"This machine" ~packing:vbox#pack () in + let hbox = GPack.hbox ~packing:frame#add () in + hbox#set_spacing 20; + ignore ( + let packing = hbox#pack in + match !icon_24x24_devices_computer_png with + | None -> GMisc.image ~stock:`DIRECTORY ~packing () + | Some pixbuf -> GMisc.image ~pixbuf ~packing () + ); + + let vbox = GPack.vbox ~packing:hbox#pack () in + vbox#set_spacing 5; + + let xen_button = + GButton.button ~label:"Xen hypervisor" + ~packing:vbox#pack () in + ignore (xen_button#connect#clicked + ~callback:(fun () -> + uri := Some local_xen_uri; + dlg#destroy ())); + let qemu_button = + GButton.button ~label:"QEMU or KVM" + ~packing:vbox#pack () in + ignore (qemu_button#connect#clicked + ~callback:(fun () -> + uri := Some local_qemu_uri; + dlg#destroy ())) in + + (* Network connections. *) + let () = + let frame = + GBin.frame ~label:"Local network" + ~packing:(vbox#pack ~expand:true) () in + let hbox = GPack.hbox ~packing:frame#add () in + hbox#set_spacing 20; + ignore (GMisc.image ~stock:`NETWORK ~packing:hbox#pack ()); + + let vbox = GPack.vbox ~packing:(hbox#pack ~expand:true) () in + vbox#set_spacing 5; + + let cols = new GTree.column_list in + (*let col_icon = cols#add Gobject.Data.string in*) + let col_name = cols#add Gobject.Data.string in + let model = GTree.list_store cols in + + let icons = GTree.icon_view + ~selection_mode:`SINGLE ~model + ~height:200 + ~packing:(vbox#pack ~expand:true ~fill:true) () in + icons#set_border_width 4; + + (*icons#set_pixbuf_column col_icon;*) + icons#set_text_column col_name; + + let refresh () = + model#clear (); + let services = !find_libvirtd_with_zeroconf () in + + (*let pixbuf = !icon_16x16_devices_computer_png in*) + List.iter ( + fun (name, _) -> + let row = model#append () in + model#set ~row ~column:col_name name; + (*match pixbuf with + | None -> () + | Some pixbuf -> model#set ~row ~column:col_icon pixbuf*) + ) services + in + refresh (); + + let hbox = GPack.hbox ~packing:vbox#pack () in + let refresh_button = + GButton.button ~label:"Refresh" ~stock:`REFRESH ~packing:hbox#pack () in + let open_button = + GButton.button ~label:"Open" ~packing:hbox#pack () in + + ignore (refresh_button#connect#clicked ~callback:refresh); + + (* Function callback when someone selects and hits Open. *) + let callback () = + match icons#get_selected_items with + | [] -> () (* nothing selected *) + | path :: _ -> + let row = model#get_iter path in + let name = model#get ~row ~column:col_name in + let services = !find_libvirtd_with_zeroconf () in + try + uri := Some (List.assoc name services); + dlg#destroy () + with + Not_found -> () in + + ignore (open_button#connect#clicked ~callback) in + + (* Custom connections. *) + let () = + let frame = + GBin.frame ~label:"URI connection" ~packing:vbox#pack () in + let hbox = GPack.hbox ~packing:frame#add () in + hbox#set_spacing 20; + ignore (GMisc.image ~stock:`CONNECT ~packing:hbox#pack ()); + + let hbox = GPack.hbox ~packing:(hbox#pack ~expand:true) () in + let entry = + GEdit.entry ~text:"xen://localhost/" + ~packing:(hbox#pack ~expand:true ~fill:true) () in + let button = + GButton.button ~label:"Open" ~packing:hbox#pack () in + + ignore (button#connect#clicked + ~callback:(fun () -> + uri := Some entry#text; + dlg#destroy ())); + + () in + + + (* Just a cancel button in the action area. *) + let cancel_button = + GButton.button ~label:"Cancel" + ~packing:dlg#action_area#pack () in + ignore (cancel_button#connect#clicked + ~callback:(fun () -> + uri := None; + dlg#destroy ())); + + dlg#show (); + + (* Enter Gtk main loop recursively. *) + GMain.main (); + + match !uri with | None -> () | Some uri -> Vc_connections.open_connection uri + +(* Callback from the Connect button drop-down menu. *) +let open_local_xen () = + Vc_connections.open_connection local_xen_uri + +let open_local_qemu () = + Vc_connections.open_connection local_qemu_uri diff --git a/virt-ctrl/vc_connection_dlg.mli b/virt-ctrl/vc_connection_dlg.mli index bfd7ba4..0102713 100644 --- a/virt-ctrl/vc_connection_dlg.mli +++ b/virt-ctrl/vc_connection_dlg.mli @@ -20,4 +20,24 @@ *) (** The connection dialog. *) -val open_connection : unit -> unit +val open_connection : GWindow.window -> unit -> unit + +(** Quick connect to local Xen. *) +val open_local_xen : unit -> unit + +(** Quick connect to local QEMU or KVM. *) +val open_local_qemu : unit -> unit + +type name = string +type uri = string +type service = name * uri + +(** Hook to find libvirtd network services with zeroconf using some + external method, eg. D-Bus or Avahi. *) +val find_libvirtd_with_zeroconf : (unit -> service list) ref + +(** Hooks for icons. *) +val icon_16x16_devices_computer_png : GdkPixbuf.pixbuf option ref +val icon_24x24_devices_computer_png : GdkPixbuf.pixbuf option ref +val icon_32x32_devices_computer_png : GdkPixbuf.pixbuf option ref +val icon_48x48_devices_computer_png : GdkPixbuf.pixbuf option ref diff --git a/virt-ctrl/vc_dbus.ml b/virt-ctrl/vc_dbus.ml index 5117482..278b1fc 100644 --- a/virt-ctrl/vc_dbus.ml +++ b/virt-ctrl/vc_dbus.ml @@ -19,3 +19,293 @@ 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 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 "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 "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 "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 -> + eprintf "warning: ignored unknown message %s from %s\n%!" + member interface + ); + 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 "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 diff --git a/virt-ctrl/vc_dbus.mli b/virt-ctrl/vc_dbus.mli new file mode 100644 index 0000000..884093e --- /dev/null +++ b/virt-ctrl/vc_dbus.mli @@ -0,0 +1,22 @@ +(* 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. +*) + +(* No public API. If loaded this module hooks into Vc_connection_dlg. *) -- 1.8.3.1