From e2e705307171a21a413f6ea47baf52d2fb44a6b3 Mon Sep 17 00:00:00 2001 From: Richard Jones Date: Fri, 9 Jul 2010 13:48:40 +0100 Subject: [PATCH] Version 0.0.2 --- HACKING | 6 +-- README | 14 ++++--- configure.ac | 2 +- filetree.ml | 2 - utils.ml | 2 + utils.mli | 3 ++ window.ml | 119 ++++++++++++++++++++++++++++++++++++++++++----------------- 7 files changed, 102 insertions(+), 46 deletions(-) diff --git a/HACKING b/HACKING index ab5f83a..468162e 100644 --- a/HACKING +++ b/HACKING @@ -51,9 +51,9 @@ safe, and in any case we don't want the main thread to block because it performs some long-running operation by accident). The slave thread is defined in the Slave module (interface: -'slave.mli') and all slave_* files. The Slave module also defines -what commands are possible. Every other module and file is part of -the main thread except for a few utility / library modules. +'slave.mli') and the slave.ml implementation. The Slave module also +defines what commands are possible. Every other module and file is +part of the main thread except for a few utility modules. The main thread starts in the module Main. diff --git a/README b/README index f37102f..b21b50d 100644 --- a/README +++ b/README @@ -12,14 +12,16 @@ script and it will tell you what's missing). We strongly suggest you run the program like this: - ./guestfs-browser [--verbose] [--write] --connect qemu:///system + guestfs-browser [--verbose] [--write] --connect qemu:///system or: - ./guestfs-browser [--verbose] [--write] disk.img + guestfs-browser [--verbose] [--write] disk.img --verbose enables debug level messages and is recommended. ---write enables writes to the filesystems and is *not* recommended. +--write enables writes to the filesystems and is *not* recommended for +casual users. ---connect tells the program which libvirt to connect to, and is -required at the moment if you want to use libvirt, because we have not -yet implemented the associated menu options. +--connect tells the program which libvirt URI to connect to. + +Note that libguestfs cannot access remote storage, so accessing a +remote libvirt URI will usually not work. diff --git a/configure.ac b/configure.ac index 8f45e75..872c5c0 100644 --- a/configure.ac +++ b/configure.ac @@ -15,7 +15,7 @@ dnl You should have received a copy of the GNU General Public License along dnl with this program; if not, write to the Free Software Foundation, Inc., dnl 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -AC_INIT([guestfs-browser],[0.0.1]) +AC_INIT([guestfs-browser],[0.0.2]) AM_INIT_AUTOMAKE([foreign]) AC_CONFIG_MACRO_DIR([m4]) diff --git a/filetree.ml b/filetree.ml index 122320e..797c3df 100644 --- a/filetree.ml +++ b/filetree.ml @@ -24,8 +24,6 @@ open Utils module G = Guestfs -let unique = let i = ref 0 in fun () -> incr i; !i - (* The type of the hidden column used to implement on-demand loading. * We are going to store these in the model as simple ints because that * is easier on the GC. Don't change these numbers! diff --git a/utils.ml b/utils.ml index a3eca86..94a59a0 100644 --- a/utils.ml +++ b/utils.ml @@ -60,3 +60,5 @@ let human_size_1k i = sprintf "%.1fM" (Int64.to_float i /. 1024.) else sprintf "%.1fG" (Int64.to_float i /. 1024. /. 1024.) + +let unique = let i = ref 0 in fun () -> incr i; !i diff --git a/utils.mli b/utils.mli index 0df3a43..1959ef6 100644 --- a/utils.mli +++ b/utils.mli @@ -52,3 +52,6 @@ val utf8_rarrow : string (** UTF-8 RIGHTWARDS ARROW *) val human_size_1k : int64 -> string (** Convert a number (of 1K blocks) into a human readable string. *) + +val unique : unit -> int + (** Return a new integer each time called. *) 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 -- 1.8.3.1