X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=window.ml;h=baa63b2b78808ebb41e219ba26e4d08e78b3708a;hb=23a1eac79ffcbab1801b89430fc0354e44cf7599;hp=5f3852a35ace6f54d0c4ce2cd2a6a3ff1850ab1d;hpb=73f1dc10b4279528818fe0fda33daf4c34488d21;p=guestfs-browser.git diff --git a/window.ml b/window.ml index 5f3852a..baa63b2 100644 --- a/window.ml +++ b/window.ml @@ -19,273 +19,333 @@ open Printf open Utils +open Slave_types module G = Guestfs -(* Main window state. *) -type window_state = { - window : GWindow.window; - view : Filetree.t; - vmcombo : GEdit.combo_box GEdit.text_combo; - throbber : GMisc.image; - throbber_static : GdkPixbuf.pixbuf; - statusbar : GMisc.statusbar; - statusbar_context : GMisc.statusbar_context; - progress_bar : GRange.progress_bar; +type connect_menu = { + connect_menu : GMenu.menu; + connect_kvm_item : GMenu.menu_item; + connect_xen_item : GMenu.menu_item; + connect_none_item : GMenu.menu_item; + connect_uri_item : GMenu.menu_item; + open_disk_item : GMenu.menu_item; + reopen_item : GMenu.menu_item; + quit_item : GMenu.menu_item; } -(* Set the statusbar text. *) -let set_statusbar ws msg = - ws.statusbar_context#pop (); - ignore (ws.statusbar_context#push msg) - -let clear_statusbar ws = set_statusbar ws "" - -(* Clear the filetree. *) -let clear_view ws = - Filetree.clear ws.view - -(* Callback from Connect -> ... menu items. *) -let rec connect_to ws uri = - (match uri with - | None -> set_statusbar ws "Connecting to default libvirt ..." - | Some uri -> set_statusbar ws (sprintf "Connecting to %s ..." uri) - ); - clear_view ws; - Slave.discard_command_queue (); - Slave.connect uri (when_connected ws uri) - -(* Called back when connected to a new hypervisor. *) -and when_connected ws uri doms = - (match uri with - | None -> set_statusbar ws "Connected to default libvirt" - | Some uri -> set_statusbar ws (sprintf "Connected to %s" uri) - ); - populate_vmcombo ws doms - -and populate_vmcombo ws doms = - (* Populate the VM combo box. *) - let combo, (model, column) = ws.vmcombo in - model#clear (); - List.iter ( - fun { Slave.dom_name = name } -> - let row = model#append () in - model#set ~row ~column name - ) doms - -(* When a new domain is selected by the user, eg through vmcombo. *) -let rec open_domain ws name = - set_statusbar ws (sprintf "Opening %s ..." name); - clear_view ws; - Slave.discard_command_queue (); - Slave.open_domain name (when_opened_domain ws name) - -(* Called back when domain was opened successfully. *) -and when_opened_domain ws name data = - debug "when_opened_domain callback"; - set_statusbar ws (sprintf "Opened %s" name); - when_opened_common ws name data - -(* When a set of disk images is selected by the user. *) -and open_disk_images ws images = - match images with - | [] -> () - | images -> - set_statusbar ws "Opening disks ..."; - clear_view ws; - Slave.discard_command_queue (); - Slave.open_images images (when_opened_disk_images ws images) - -(* Called back when disk image(s) were opened successfully. *) -and when_opened_disk_images ws images data = - match images with - | [] -> () - | (image, _) :: _ -> - debug "when_opened_disk_images callback"; - set_statusbar ws "Opened disk"; - when_opened_common ws image data - -(* Common code for when_opened_domain/when_opened_disk_images. *) -and when_opened_common ws name data = - (* Dump some of the inspection data in debug messages. *) - List.iter (fun (dev, t) -> debug "filesystem: %s: %s" dev t) - data.Slave.insp_all_filesystems; - List.iter ( - fun { Slave.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.Slave.insp_oses; - - Filetree.add ws.view name data - -let throbber_busy ws () = - (*throbber#set_pixbuf animation*) - (* XXX Workaround because no binding for GdkPixbufAnimation: *) - let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in - ws.throbber#set_file file - -let throbber_idle ws () = - ws.throbber#set_pixbuf ws.throbber_static - -let progress ws (position, total) = - ws.progress_bar#set_fraction - (Int64.to_float position /. Int64.to_float total) - -(* 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 failure ws exn = - let title = "Error" in - let msg = Printexc.to_string exn in - debug "failure hook: %s" msg; - let icon = GMisc.image () in - icon#set_stock `DIALOG_ERROR; - icon#set_icon_size `DIALOG; - GToolbox.message_box ~title ~icon msg - -let rec open_main_window () = - (* I prototyped the basic window layout using Glade, but have - * implemented it by hand to give us more flexibility. - *) +type guest_menu = { + guest_menu : GMenu.menu; + guest_inspection_item : GMenu.menu_item; +} + +type help_menu = { + help_menu : GMenu.menu; + about_item : GMenu.menu_item; +} + +class window = + (* 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 (* Menus. *) - let connect_kvm_item, connect_xen_item, connect_none_item, _, _ = - make_menubar window vbox ~packing:vbox#pack () in - - (* Top toolbar. *) - let vmcombo, 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 - ignore (statusbar_context#push title); - - window#show (); - - (* Construct the window_state struct. *) - let ws = { - window = window; - view = view; - vmcombo = vmcombo; - throbber = throbber; throbber_static = throbber_static; - statusbar = statusbar; statusbar_context = statusbar_context; - progress_bar = progress_bar - } in - - (* 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 () -> connect_to ws (Some "qemu:///system"))); - ignore (connect_xen_item#connect#activate - ~callback:(fun () -> connect_to ws (Some "xen:///"))); - ignore (connect_none_item#connect#activate - ~callback:(fun () -> connect_to ws None)); - - (* VM combo box when changed by the user. *) - let combo, (model, column) = ws.vmcombo in - ignore ( - combo#connect#changed - ~callback:( - fun () -> - match combo#active_iter with - | None -> () (* nothing selected *) - | Some row -> open_domain ws (model#get ~row ~column) - ) - ); - - Filetree.set_status_fn view (set_statusbar ws); - - (* Return the window_state struct. *) - ws - -and make_menubar window vbox ~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_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 - - (* Quit. *) - let quit _ = GMain.quit (); false in - ignore (window#connect#destroy ~callback:GMain.quit); - ignore (window#event#connect#delete ~callback:quit); - ignore (quit_item#connect#activate - ~callback:(fun () -> ignore (quit ()); ())); - - window#add_accel_group accel_group; - - connect_kvm_item, connect_xen_item, connect_none_item, - connect_uri_item, open_image_item - -(* 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 + + let connect_menu = + let menu = factory#add_submenu "_Connect" in + let factory = new GMenu.factory menu ~accel_group in + let kvm = factory#add_item "Connect to local _KVM hypervisor" in + let xen = factory#add_item "Connect to local _Xen hypervisor" in + let none = factory#add_item "_Connect to default hypervisor" in + let uri = factory#add_item "Connect to a _libvirt URI ..." in + ignore (factory#add_separator ()); + let opend = factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in + ignore (factory#add_separator ()); + let reopen = factory#add_item "Reopen current guest" in + ignore (factory#add_separator ()); + let quit = factory#add_item "E_xit" ~key:GdkKeysyms._Q in + { connect_menu = menu; connect_kvm_item = kvm; + connect_xen_item = xen; connect_none_item = none; + connect_uri_item = uri; + open_disk_item = opend; reopen_item = reopen; quit_item = quit } in + + let guest_menu = + let menu = factory#add_submenu "_Guest" in + let factory = new GMenu.factory menu ~accel_group in + let inspection = factory#add_item "Operating system information ..." in + { guest_menu = menu; guest_inspection_item = inspection } in + + let help_menu = + let menu = factory#add_submenu "_Help" in + let factory = new GMenu.factory menu ~accel_group in + let about = factory#add_item "About guest filesystem browser ..." in + { help_menu = menu; about_item = about } in + + (* Top toolbar. *) + let hbox = + let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in + hbox#pack (mklabel "Guest: "); + hbox in (* Combo box for displaying virtual machine names. *) - hbox#pack (mklabel "Guest: "); let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in + (* 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_static = Throbber.static () in + let throbber_animation = Throbber.animation () in let throbber = - GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in + (* Workaround for http://caml.inria.fr/mantis/view.php?id=4732 *) + let from = Obj.magic 3448763 (* `END *) in + GMisc.image ~pixbuf:throbber_static ~packing:(hbox#pack ~from) () in - vmcombo, throbber, static + (* Main part of display is the file tree. *) + (* Create the filetree inside a scrolled window. *) + let sw = GBin.scrolled_window + ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS + ~packing:(vbox#pack ~expand:true ~fill:true) () in + let tree = new Filetree.tree ~packing:sw#add () in -and make_filetree ~packing () = - let sw = - GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in - Filetree.create ~packing:sw#add () + (* Status bar and progress bar at the bottom. *) + 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 + + (* Signals. *) + let connect_kvm_signal = new GUtil.signal () in + let connect_xen_signal = new GUtil.signal () in + let connect_none_signal = new GUtil.signal () in + let connect_uri_signal = new GUtil.signal () in + let open_disk_signal = new GUtil.signal () in + let reopen_signal = new GUtil.signal () in + let inspection_signal = new GUtil.signal () in + let about_signal = new GUtil.signal () in + +object (self) + inherit GUtil.ml_signals [connect_kvm_signal#disconnect; + connect_xen_signal#disconnect; + connect_none_signal#disconnect; + connect_uri_signal#disconnect; + open_disk_signal#disconnect; + reopen_signal#disconnect; + inspection_signal#disconnect; + about_signal#disconnect] + + method connect_kvm_signal = connect_kvm_signal#connect ~after + method connect_xen_signal = connect_xen_signal#connect ~after + method connect_none_signal = connect_none_signal#connect ~after + method connect_uri_signal = connect_uri_signal#connect ~after + method open_disk_signal = open_disk_signal#connect ~after + method reopen_signal = reopen_signal#connect ~after + method inspection_signal = inspection_signal#connect ~after + method about_signal = about_signal#connect ~after + + initializer + ignore (statusbar_context#push title); + window#show (); + + (* Quit. *) + let quit _ = GMain.quit (); false in + ignore (window#connect#destroy ~callback:GMain.quit); + ignore (window#event#connect#delete ~callback:quit); + ignore (connect_menu.quit_item#connect#activate + ~callback:(fun () -> ignore (quit ()); ())); + + (* Accel_group. *) + window#add_accel_group accel_group; + + (* Menu entries emit signals. *) + ignore (connect_menu.connect_kvm_item#connect#activate + ~callback:connect_kvm_signal#call); + ignore (connect_menu.connect_xen_item#connect#activate + ~callback:connect_xen_signal#call); + ignore (connect_menu.connect_none_item#connect#activate + ~callback:connect_none_signal#call); + ignore (connect_menu.connect_uri_item#connect#activate + ~callback:connect_uri_signal#call); + ignore (connect_menu.open_disk_item#connect#activate + ~callback:open_disk_signal#call); + ignore (connect_menu.reopen_item#connect#activate + ~callback:reopen_signal#call); + ignore (guest_menu.guest_inspection_item#connect#activate + ~callback:inspection_signal#call); + ignore (help_menu.about_item#connect#activate + ~callback:about_signal#call); + + (* 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) + + (* Return the filetree. *) + method tree = tree + + (* Connect to the given URI. *) + method connect_to uri () = + tree#clear (); + 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 -(* Do what the user asked on the command line. *) -let rec run_cli_request ws = function + (* Populate the VM combo box. *) + method private populate_vmcombo doms = + let combo, (model, column) = vmcombo in + model#clear (); + List.iter ( + fun { dom_name = name } -> + let row = model#append () in + model#set ~row ~column name + ) doms + + (* When a new domain is selected by the user, eg through vmcombo. *) + method private open_domain name = + tree#clear (); + 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 open_disk_images images = + match images with + | [] -> () + | images -> + tree#clear (); + 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 + + (* Called to reopen the handle. *) + method reopen () = + tree#clear (); + Slave.discard_command_queue (); + Slave.reopen self#when_reopened + + method private when_reopened data = + debug "when_reopened callback"; + self#when_opened_common "Reopened"(*XXX we lost the original name*) 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; + + tree#add_os name data + + (* Public callbacks. *) + method throbber_busy () = + throbber#set_pixbuf throbber_animation + + 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. + *) + 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 -> - open_disk_images ws 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 (when_connected_cli_request ws guest) -and when_connected_cli_request ws guest doms = - populate_vmcombo ws 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 { Slave.dom_name = name } -> name) doms) in - - let combo, _ = ws.vmcombo in - combo#set_active i + 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 combo, _ = vmcombo in + combo#set_active i + +end