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