X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=window.ml;fp=window.ml;h=f58d76fc926c0fd5db5bc51c82885adfb3393379;hb=e2e705307171a21a413f6ea47baf52d2fb44a6b3;hp=f5ec47d1047d0f7c76d7d2b6c70c4567ad55ecdb;hpb=982d415dc9b200c870406240ddd62efa2dd6ba6d;p=guestfs-browser.git

diff --git a/window.ml b/window.ml
index f5ec47d..f58d76f 100644
--- a/window.ml
+++ b/window.ml
@@ -50,8 +50,13 @@ let rec open_main_window () =
   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
 
@@ -140,18 +145,19 @@ let rec open_main_window () =
     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
@@ -176,6 +182,15 @@ and failure ds exn =
   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 ()));
@@ -193,18 +208,33 @@ and got_domains ds doms =
     (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. *)
@@ -214,6 +244,8 @@ and opened ds rw =
  * 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;
@@ -312,20 +344,41 @@ and got_volume ds rw vol =
   )
 
 (* 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.
@@ -340,7 +393,5 @@ and intro_label () =
 
 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