New connection dialog with support for Avahi detection of libvirtd.

4 files changed, 511 insertions, 8 deletions

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. *)