X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=window.ml;h=6ede415e361fa64a22660a38c559e4972cb44c97;hb=1d7c4274827064c684d831c9ef51b198ba8798a2;hp=f5ec47d1047d0f7c76d7d2b6c70c4567ad55ecdb;hpb=277d7009668cce99d0534d780c3984675bf20cd0;p=guestfs-browser.git diff --git a/window.ml b/window.ml index f5ec47d..6ede415 100644 --- a/window.ml +++ b/window.ml @@ -19,39 +19,24 @@ open Printf open Utils +open Slave_types module G = Guestfs -let (//) = Filename.concat - -(* Display state. *) -type display_state = { - window : GWindow.window; - throbber_busy : unit -> unit; - throbber_idle : unit -> unit; - set_statusbar : string -> unit; - clear_statusbar : unit -> unit; - set_vmlist : string list -> unit; - clear_vmlist : unit -> unit; - clear_notebook : unit -> unit; - filesystem : GPack.box; - notebook : GPack.notebook; -} - -let rec open_main_window () = - let title = "Guest Filesystem Browser" in - let window = GWindow.window ~width:700 ~height:700 ~title () in - let vbox = GPack.vbox ~packing:window#add () in - - (* Do the menus. *) +let make_menubar window (vbox : GPack.box) ~packing () = let menubar = GMenu.menu_bar ~packing:vbox#pack () in let factory = new GMenu.factory menubar in let accel_group = factory#accel_group in 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 @@ -62,285 +47,269 @@ let rec open_main_window () = ignore (quit_item#connect#activate ~callback:(fun () -> ignore (quit ()); ())); - (* Top status area. *) - let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in - hbox#pack (mklabel "Guest: "); + window#add_accel_group accel_group; + + connect_kvm_item, connect_xen_item, connect_none_item, + connect_uri_item, open_image_item - (* List of VMs. *) +(* Top toolbar. In fact, not a toolbar because you don't seem to be + * able to put a combo box into a toolbar, so it's just an hbox for now. + *) +and make_toolbar ~packing () = + let hbox = GPack.hbox ~border_width:4 ~packing () in + + (* Combo box for displaying virtual machine names. *) + hbox#pack (mklabel "Guest: "); let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in - let set_vmlist names = + + (* Refresh button. + * http://stackoverflow.com/questions/2188659/stock-icons-not-shown-on-buttons + *) + let refresh_button = + let image = GMisc.image ~stock:`REFRESH () in + let b = GButton.button ~packing:hbox#pack () in + b#set_image (image :> GObj.widget); + b in + + (* Throbber. *) + let static = Throbber.static () in + (*let animation = Throbber.animation () in*) + let throbber = + (* Workaround for http://caml.inria.fr/mantis/view.php?id=4732 *) + let from = Obj.magic 3448763 (* `END *) in + GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from) () in + + vmcombo, refresh_button, throbber, static + +and make_filetree ~packing () = + (* Create the filetree inside a scrolled window. *) + let sw = + GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in + let tree = new Filetree.tree ~packing:sw#add () in + + (* Wire up the loosely-coupled external components of the filetree. + * See the note about signals in {!Filetree.tree} documentation. + *) + ignore (tree#op_checksum_file + ~callback:(Op_checksum_file.checksum_file tree)); + ignore (tree#op_copy_regvalue + ~callback:(Op_copy_regvalue.copy_regvalue tree)); + ignore (tree#op_disk_usage + ~callback:(Op_disk_usage.disk_usage tree)); + ignore (tree#op_download_as_reg + ~callback:(Op_download_as_reg.download_as_reg tree)); + ignore (tree#op_download_dir_find0 + ~callback:(Op_download_dir_find0.download_dir_find0 tree)); + ignore (tree#op_download_dir_tarball + ~callback:(Op_download_dir_tarball.download_dir_tarball tree)); + ignore (tree#op_download_file + ~callback:(Op_download_file.download_file tree)); + ignore (tree#op_file_information + ~callback:(Op_file_information.file_information tree)); + ignore (tree#op_inspection_dialog + ~callback:(Op_inspection_dialog.inspection_dialog tree)); + ignore (tree#op_view_file + ~callback:(Op_view_file.view_file tree)); + + tree + +class window = + (* I prototyped the basic window layout using Glade, but have + * implemented it by hand to give us more flexibility. + *) + let title = "Guest Filesystem Browser" in + let window = GWindow.window ~width:700 ~height:700 ~title () in + let vbox = GPack.vbox ~packing:window#add () in + + (* Menus. *) + let connect_kvm_item, connect_xen_item, connect_none_item, _, _ = + make_menubar window vbox ~packing:vbox#pack () in + + (* Top toolbar. *) + let vmcombo, refresh_button, throbber, throbber_static = + make_toolbar ~packing:vbox#pack () in + + (* Main part of display is the file tree. *) + let view = make_filetree ~packing:(vbox#pack ~expand:true ~fill:true) () in + + (* Status bar and progress bar. *) + let hbox = GPack.hbox ~spacing:4 ~packing:vbox#pack () in + let progress_bar = GRange.progress_bar ~packing:hbox#pack () in + let statusbar = GMisc.statusbar ~packing:(hbox#pack ~expand:true) () in + let statusbar_context = statusbar#new_context ~name:"Standard" in + +object (self) + initializer + ignore (statusbar_context#push title); + window#show (); + + (* Connect up the callback for menu entries etc. These require the + * window_state struct in callbacks. + *) + + (* Connect to different hypervisors. *) + ignore (connect_kvm_item#connect#activate + ~callback:(fun () -> self#connect_to (Some "qemu:///system"))); + ignore (connect_xen_item#connect#activate + ~callback:(fun () -> self#connect_to (Some "xen:///"))); + ignore (connect_none_item#connect#activate + ~callback:(fun () -> self#connect_to None)); + + (* VM combo box when changed by the user. + * The refresh button acts like changing the VM combo too. + *) + let combo, (model, column) = vmcombo in + ignore ( + combo#connect#changed + ~callback:( + fun () -> + match combo#active_iter with + | None -> () (* nothing selected *) + | Some row -> self#open_domain (model#get ~row ~column) + ) + ); + ignore ( + refresh_button#connect#clicked + ~callback:( + fun () -> + match combo#active_iter with + | None -> () (* nothing selected *) + | Some row -> self#open_domain (model#get ~row ~column) + ) + ) + + (* Set the statusbar text. *) + method set_statusbar msg = + statusbar_context#pop (); + ignore (statusbar_context#push msg) + + (* Clear the filetree. *) + method private clear_view () = + view#clear () + + (* Callback from Connect -> ... menu items. *) + method private connect_to uri = + self#clear_view (); + Slave.discard_command_queue (); + Slave.connect uri (self#when_connected uri) + + (* Called back when connected to a new hypervisor. *) + method private when_connected uri doms = + self#populate_vmcombo doms + + (* Populate the VM combo box. *) + method private populate_vmcombo doms = let combo, (model, column) = vmcombo in model#clear (); List.iter ( - fun name -> + fun { dom_name = name } -> let row = model#append () in model#set ~row ~column name - ) names - in - let clear_vmlist () = set_vmlist [] in + ) doms + + (* When a new domain is selected by the user, eg through vmcombo. *) + method private open_domain name = + self#clear_view (); + Slave.discard_command_queue (); + Slave.open_domain name (self#when_opened_domain name) + + (* Called back when domain was opened successfully. *) + method private when_opened_domain name data = + debug "when_opened_domain callback"; + self#when_opened_common name data + + (* When a set of disk images is selected by the user. *) + method private open_disk_images images = + match images with + | [] -> () + | images -> + self#clear_view (); + Slave.discard_command_queue (); + Slave.open_images images (self#when_opened_disk_images images) + + (* Called back when disk image(s) were opened successfully. *) + method private when_opened_disk_images images data = + match images with + | [] -> () + | (image, _) :: _ -> + debug "when_opened_disk_images callback"; + self#when_opened_common image data + + (* Common code for when_opened_domain/when_opened_disk_images. *) + method private when_opened_common name data = + (* Dump some of the inspection data in debug messages. *) + List.iter (fun (dev, t) -> debug "filesystem: %s: %s" dev t) + data.insp_all_filesystems; + List.iter ( + fun { insp_root = root; insp_type = typ; insp_distro = distro; + insp_major_version = major; insp_minor_version = minor } -> + debug "root device %s contains %s %s %d.%d" root typ distro major minor; + ) data.insp_oses; - (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *) - let static = Throbber.static () in - (*let animation = Throbber.animation () in*) - let throbber = - GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in - let throbber_busy () = + view#add_os name data + + (* Public callbacks. *) + method throbber_busy () = (*throbber#set_pixbuf animation*) - (* Workaround because no binding for GdkPixbufAnimation: *) + (* XXX Workaround because no binding for GdkPixbufAnimation: *) let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in throbber#set_file file - and throbber_idle () = - throbber#set_pixbuf static - in - - (* Tabbed pane ("notebook") filling the main window. *) - let nb = GPack.notebook ~scrollable:true - ~packing:(vbox#pack ~expand:true ~fill:true) () in - let filesystem = GPack.vbox () in - filesystem#add (intro_label () :> GObj.widget); - ignore (nb#append_page - ~tab_label:(mklabel "Filesystem") (filesystem :> GObj.widget)); - let clear_notebook () = - nb#goto_page 0; - (* Remove all tabs except the first ("Filesystem") tab ... *) - List.iter nb#remove (List.tl nb#all_children); - (* ... and clear out the filesystem tab. *) - List.iter filesystem#remove filesystem#all_children - in - - (* Status bar at the bottom of the screen. *) - let set_statusbar = - let statusbar = GMisc.statusbar ~packing:vbox#pack () in - let context = statusbar#new_context ~name:"Standard" in - ignore (context#push title); - fun msg -> - context#pop (); - ignore (context#push msg) - in - let clear_statusbar () = set_statusbar "" in - - window#show (); - window#add_accel_group accel_group; - (* display_state which is threaded through all the other callbacks, - * allowing callbacks to update the window. + method throbber_idle () = + throbber#set_pixbuf throbber_static + + method progress (position, total) = + if position = 0L && total = 1L then + progress_bar#pulse () + else ( + let frac = Int64.to_float position /. Int64.to_float total in + if frac < 0. || frac > 1. then + eprintf "warning: progress bar out of range: %Ld / %Ld (%g)\n" + position total frac; + let frac = if frac < 0. then 0. else if frac > 1. then 1. else frac in + progress_bar#set_fraction frac + ) + + (* This is called in the main thread whenever a command fails in the + * slave thread. The command queue has been cleared before this is + * called, so our job here is to reset the main window, and if + * necessary to turn the exception into an error message. *) - let ds = { - window = window; - throbber_busy = throbber_busy; throbber_idle = throbber_idle; - set_statusbar = set_statusbar; clear_statusbar = clear_statusbar; - set_vmlist = set_vmlist; clear_vmlist = clear_vmlist; - clear_notebook = clear_notebook; - filesystem = filesystem; notebook = nb; - } in - - (* Set up some callbacks which require access to the display_state. *) - ignore ( - let combo, (model, column) = vmcombo 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)) - ); - - ignore (connect_item#connect#activate ~callback:(connect_dialog ds)); - ignore (open_item#connect#activate ~callback:(open_dialog ds)); - - (* Return the display state. *) - ds - -(* Convenience function to make a label containing some text. It is - * returned as a generic widget. - *) -and mklabel text = - (GMisc.label ~text () :> GObj.widget) - -(* This is called in the main thread whenever a command fails in the - * slave thread. The command queue has been cleared before this is - * called, so our job here is to reset the main window, and if - * necessary to turn the exception into an error message. - *) -and failure ds exn = - let title = "Error" in - let msg = Printexc.to_string exn in - debug "thread id %d: failure hook: %s" (Thread.id (Thread.self ())) msg; - let icon = GMisc.image () in - icon#set_stock `DIALOG_ERROR; - icon#set_icon_size `DIALOG; - GToolbox.message_box ~title ~icon msg - -(* 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 ())); - let msg = - match uri with - | None -> "Connected to libvirt" - | Some uri -> sprintf "Connected to %s" uri in - ds.set_statusbar msg; - Slave.get_domains (got_domains ds) - -(* This is called in the main thread when we've got the list of domains. *) -and got_domains ds doms = - let doms = List.map (fun { Slave.dom_name = name } -> name) doms in - debug "thread id %d: got_domains callback: (%s)" - (Thread.id (Thread.self ())) (String.concat " " doms); - ds.set_vmlist doms - -(* 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 - -(* 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 - -and opened ds rw = - ds.clear_statusbar (); - ds.clear_notebook (); - - (* Get the list of mountable filesystems. *) - Slave.get_volumes (got_volume ds rw) - -(* This callback is called once for each mountable filesystem that is - * found in a guest. - *) -and got_volume ds rw vol = - let dev = vol.Slave.vol_device in - debug "thread id %d: got_volume callback: %s" - (Thread.id (Thread.self ())) dev; - - (* What's on the tab. *) - let tab = - match vol.Slave.vol_label with - | "" -> sprintf "%s" dev - | label -> sprintf "%s (%s)" dev label in - - (* What's on the notebook page. *) - let page = - let vbox = GPack.vbox () in - - (* VFS stats table. *) - - (* For calculations, see libguestfs/tools/virt-df. *) - let st = vol.Slave.vol_statvfs in - let factor = st.G.bsize /^ 1024L in - - (* Right-aligned label with width, for stats table. *) - let mklabelh text = - let markup = "" ^ text ^ "" in - let label = GMisc.label ~markup ~xalign:1. () in - label#set_width_chars 12; - (label :> GObj.widget) - and mklabelr text = - let label = GMisc.label ~text ~selectable:true ~xalign:1. () in - label#set_width_chars 12; - (label :> GObj.widget) + method failure exn = + let raw_msg = Printexc.to_string exn in + debug "failure hook: %s" raw_msg; + + let title, msg = pretty_string_of_exn exn in + let icon = GMisc.image () in + icon#set_stock `DIALOG_ERROR; + icon#set_icon_size `DIALOG; + GToolbox.message_box ~title ~icon msg + + (* Do what the user asked on the command line. *) + method run_cli_request = function + | Cmdline.Empty_window -> () + | Cmdline.Open_images images -> + self#open_disk_images images + | Cmdline.Open_guest guest -> + (* Open libvirt connection, and in the callback open the guest. *) + let uri = connect_uri () in + Slave.connect uri (self#when_connected_cli_request guest) + + method private when_connected_cli_request guest doms = + self#populate_vmcombo doms; + + (* "guest" should match a domain in "doms". Check this and + * get the index of it. + *) + let rec loop i = function + | [] -> + failwith "guest %s not found (do you need to use --connect?)" guest + | d::ds when d = guest -> i + | _::ds -> loop (i+1) ds in + let i = loop 0 (List.map (fun { dom_name = name } -> name) doms) in - let stats = GPack.table ~columns:4 ~rows:5 - ~homogeneous:true ~col_spacings:4 ~row_spacings:4 - ~packing:vbox#pack () in - stats#attach ~top:0 ~left:0 (mklabelh "1K-blocks"); - stats#attach ~top:0 ~left:1 (mklabelh "Used"); - stats#attach ~top:0 ~left:2 (mklabelh "Available"); - stats#attach ~top:0 ~left:3 (mklabelh "Use%"); - let blocks = st.G.blocks *^ factor in - stats#attach ~top:1 ~left:0 (mklabelr (sprintf "%Ld" blocks)); - let used = (st.G.blocks -^ st.G.bfree) *^ factor in - stats#attach ~top:1 ~left:1 (mklabelr (sprintf "%Ld" used)); - let available = st.G.bavail *^ factor in - stats#attach ~top:1 ~left:2 (mklabelr (sprintf "%Ld" available)); - stats#attach ~top:1 ~left:3 - (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.bfree /^ st.G.blocks))); - stats#attach ~top:2 ~left:0 (mklabelr ("= " ^ human_size_1k blocks)); - stats#attach ~top:2 ~left:1 (mklabelr ("= " ^ human_size_1k used)); - stats#attach ~top:2 ~left:2 (mklabelr ("= " ^ human_size_1k available)); - stats#attach ~top:3 ~left:0 (mklabelh "Inodes"); - stats#attach ~top:3 ~left:1 (mklabelh "IUsed"); - stats#attach ~top:3 ~left:2 (mklabelh "IFree"); - stats#attach ~top:3 ~left:3 (mklabelh "IUse%"); - stats#attach ~top:4 ~left:0 (mklabelr (sprintf "%Ld" st.G.files)); - stats#attach ~top:4 ~left:1 - (mklabelr (sprintf "%Ld" (st.G.files -^ st.G.ffree))); - stats#attach ~top:4 ~left:2 (mklabelr (sprintf "%Ld" st.G.ffree)); - stats#attach ~top:4 ~left:3 - (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.ffree /^ st.G.files))); - - (* Info table. *) - - (* Left- and right-aligned labels, for info table. *) - let mklabelr text = - let label = GMisc.label ~text ~xalign:1. () in - label#set_width_chars 9; - (label :> GObj.widget) - and mklabell text = - let label = GMisc.label ~text ~selectable:true ~xalign:0. () in - (label :> GObj.widget) - in + let combo, _ = vmcombo in + combo#set_active i - let info = GPack.table ~columns:4 ~rows:2 - ~col_spacings:4 ~row_spacings:4 - ~packing:vbox#pack () in - info#attach ~top:0 ~left:0 (mklabelr "FS label:"); - info#attach ~top:0 ~left:1 (mklabell vol.Slave.vol_label); - info#attach ~top:1 ~left:0 (mklabelr "FS type:"); - info#attach ~top:1 ~left:1 (mklabell vol.Slave.vol_type); - info#attach ~top:0 ~left:2 (mklabelr "FS UUID:"); - info#attach ~top:0 ~left:3 (mklabell vol.Slave.vol_uuid); - info#attach ~top:1 ~left:2 (mklabelr "Device:"); - info#attach ~top:1 ~left:3 (mklabell dev); - - (* Files display. *) - let sw = GBin.scrolled_window - ~packing:(vbox#pack ~expand:true ~fill:true) - ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in - let view = Filetree.filetree dev rw in - sw#add (view :> GObj.widget); - - vbox in - ignore ( - ds.notebook#append_page ~tab_label:(mklabel tab) (page :> GObj.widget) - ) - -(* 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 *) - () - -(* The introductory text which appears in the tabbed notebook to - * tell the user how to start. XXX We should add images. - *) -and intro_label () = - let text = - sprintf "Open a disk image (Connect %s Open disk image), connect to libvirt (Connect %s Connect to libvirt), or choose a guest from the \"Guest\" menu above." - utf8_rarrow utf8_rarrow in - let label = GMisc.label ~text () in - label#set_line_wrap true; - 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) +end