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
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
git.annexia.org / virt-top.git / commitdiff