let connect_menu = factory#add_submenu "_Connect" in
let factory = new GMenu.factory connect_menu ~accel_group in
- let connect_item = factory#add_item "_Connect to libvirt ..." in
- let open_item = factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in
+ let connect_kvm_item = factory#add_item "_Connect to local KVM hypervisor" in
+ let connect_xen_item = factory#add_item "_Connect to local Xen hypervisor" in
+ let connect_none_item = factory#add_item "_Connect to default hypervisor" in
+ let connect_uri_item = factory#add_item "_Connect to a libvirt URI ..." in
+ ignore (factory#add_separator ());
+ let open_image_item =
+ factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in
ignore (factory#add_separator ());
let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
combo#connect#changed
~callback:(
fun () ->
- match combo#active_iter with
- | None -> ()
- | Some row ->
- let name = model#get ~row ~column in
- ds.set_statusbar (sprintf "Opening %s ..." name);
- ds.clear_notebook ();
- Slave.discard_command_queue ();
- Slave.open_domain name (opened_domain ds))
+ Option.may (fun row -> open_domain ds (model#get ~row ~column))
+ combo#active_iter
+ )
);
- ignore (connect_item#connect#activate ~callback:(connect_dialog ds));
- ignore (open_item#connect#activate ~callback:(open_dialog ds));
+ ignore (connect_kvm_item#connect#activate
+ ~callback:(fun () -> connect ds (Some "qemu:///system")));
+ ignore (connect_xen_item#connect#activate
+ ~callback:(fun () -> connect ds (Some "xen:///")));
+ ignore (connect_none_item#connect#activate
+ ~callback:(fun () -> connect ds None));
+ ignore (connect_uri_item#connect#activate ~callback:(connect_uri_dialog ds));
+ ignore (open_image_item#connect#activate ~callback:(open_image_dialog ds));
(* Return the display state. *)
ds
icon#set_icon_size `DIALOG;
GToolbox.message_box ~title ~icon msg
+(* Perform action to open the named libvirt URI. *)
+and connect ds uri =
+ (match uri with
+ | None -> ds.set_statusbar "Connecting to default libvirt ...";
+ | Some uri -> ds.set_statusbar (sprintf "Connecting to %s ..." uri));
+ ds.clear_notebook ();
+ Slave.discard_command_queue ();
+ Slave.connect uri (connected ds uri)
+
(* This is called in the main thread when we've connected to libvirt. *)
and connected ds uri () =
debug "thread id %d: connected callback" (Thread.id (Thread.self ()));
(Thread.id (Thread.self ())) (String.concat " " doms);
ds.set_vmlist doms
+(* Perform action to open the named domain. *)
+and open_domain ds name =
+ ds.set_statusbar (sprintf "Opening %s ..." name);
+ ds.clear_notebook ();
+ Slave.discard_command_queue ();
+ Slave.open_domain name (opened_domain ds)
+
(* This callback indicates that the domain was opened successfully. *)
and opened_domain ds rw =
debug "thread id %d: opened_domain callback" (Thread.id (Thread.self ()));
- opened ds rw
+ _opened ds rw
+
+(* Perform action of opening disk image(s). *)
+and open_images ds images =
+ ds.set_statusbar (sprintf "Opening disk image %s ..."
+ (String.concat " " images));
+ ds.clear_notebook ();
+ Slave.discard_command_queue ();
+ Slave.open_images images (opened_images ds)
(* This callback indicates that local disk image(s) were opened successfully.*)
and opened_images ds rw =
debug "thread id %d: opened_images callback" (Thread.id (Thread.self ()));
- opened ds rw
+ _opened ds rw
-and opened ds rw =
- ds.clear_statusbar ();
+and _opened ds rw =
+ ds.set_statusbar ("Opening filesystems ...");
ds.clear_notebook ();
(* Get the list of mountable filesystems. *)
* found in a guest.
*)
and got_volume ds rw vol =
+ ds.clear_statusbar ();
+
let dev = vol.Slave.vol_device in
debug "thread id %d: got_volume callback: %s"
(Thread.id (Thread.self ())) dev;
)
(* Open the connect to libvirt dialog. *)
-and connect_dialog ds () =
- debug "connect menu";
- (*ds.clear_notebook ();*)
- (*Slave.discard_command_queue ();*)
- (* XXX NOT IMPL XXX *)
- ()
-
-(* Open the disk images dialog. *)
-and open_dialog ds () =
- debug "open menu";
- (*ds.clear_notebook ();*)
- (*Slave.discard_command_queue ();*)
- (* XXX NOT IMPL XXX *)
- ()
+and connect_uri_dialog ds () =
+ debug "connect_uri_dialog";
+ let title = "Choose a libvirt URI" in
+ let ok = "Connect to libvirt" in
+ let text = "NB: Remote storage cannot be accessed, so entering
+a libvirt remote URI here will probably not work." in
+ let uri = GToolbox.input_string ~title ~ok text in
+ match uri with
+ | None -> debug "connect_uri_dialog cancelled"; ()
+ | Some "" -> debug "connect to default"; connect ds None
+ | (Some s) as uri -> debug "connect to %s" s; connect ds uri
+
+(* Open the disk images dialog.
+ * XXX This can only deal with a single disk image at the moment, but
+ * underlying code can deal with multiple.
+ *)
+and open_image_dialog ds () =
+ let title = "Choose a disk image" in
+ let dlg = GWindow.file_chooser_dialog ~action:`OPEN ~title ~modal:true () in
+ dlg#add_button "Open disk image" `OPEN_IMAGE;
+ dlg#add_button "Close" `DELETE_EVENT;
+
+ let callback = function
+ | `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy ()
+ | `OPEN_IMAGE ->
+ match dlg#filename with
+ | None -> () (* nothing selected in dialog, keep dialog open *)
+ | Some filename ->
+ debug "OPEN_IMAGE response, filename = %s" filename;
+ dlg#destroy ();
+ open_images ds [filename]
+ in
+ ignore (dlg#connect#response ~callback);
+
+ dlg#show ()
(* The introductory text which appears in the tabbed notebook to
* tell the user how to start. XXX We should add images.
let run_cli_request ds = function
| Cmdline.Empty_window -> ()
- | Cmdline.Connect_to_libvirt uri ->
- Slave.connect uri (connected ds uri)
- | Cmdline.Open_disk_image images ->
- Slave.open_images images (opened_images ds)
+ | Cmdline.Connect_to_libvirt uri -> connect ds uri
+ | Cmdline.Open_disk_image images -> open_images ds images
git.annexia.org / guestfs-browser.git / blobdiff