X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=window.ml;h=323e847eb560ccba97cc8ec01cca8687044b99e4;hb=b9e8c84588873568b7fdfaeb9beb85466e84c8fa;hp=a5116fc59fbdd533adb1194a0eabd00c331dc25c;hpb=b07102fda0034da5840a9f33bd6d404a195b8cc9;p=guestfs-browser.git diff --git a/window.ml b/window.ml index a5116fc..323e847 100644 --- a/window.ml +++ b/window.ml @@ -22,36 +22,202 @@ open Utils module G = Guestfs -let (//) = Filename.concat - -(* Display state. *) -type display_state = { +(* Main window state. *) +type window_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; + 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; } +(* 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 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 (sprintf "Opening disk image %s ..." + (String.concat " " images)); + 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 :: _ as images -> + debug "when_opened_disk_images callback"; + set_statusbar ws (sprintf "Opened disk image %s" + (String.concat " " images)); + 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 + +(* 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. + *) let title = "Guest Filesystem Browser" in - let window = GWindow.window ~width:800 ~height:600 ~title () in + let window = GWindow.window ~width:700 ~height:700 ~title () in let vbox = GPack.vbox ~packing:window#add () in - (* Do the menus. *) + (* 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 ~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) + ) + ); + + 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_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,280 +228,30 @@ 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 + +(* 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 - (* List of VMs. *) + (* 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 = - let combo, (model, column) = vmcombo in - model#clear (); - List.iter ( - fun name -> - let row = model#append () in - model#set ~row ~column name - ) names - in - let clear_vmlist () = set_vmlist [] in - - (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *) + + (* Throbber. *) 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 () = - (*throbber#set_pixbuf animation*) - (* 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. - *) - 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.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 + vmcombo, throbber, static -(* 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) - 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 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 ();*) - failwith "XXX CONNECT DLG NOT IMPL" - -(* Open the disk images dialog. *) -and open_dialog ds () = - debug "open menu"; - (*ds.clear_notebook ();*) - failwith "XXX OPEN DLG NOT IMPL" - -(* 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) +and make_filetree ~packing () = + let sw = + GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in + Filetree.create ~packing:sw#add ()