From 87a075aaada42182cd7047d110f83eaa8273b78d Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Thu, 28 Jul 2011 19:28:31 +0100 Subject: [PATCH] Basic inspection data. --- .depend | 4 +- op_inspection_dialog.ml | 183 +++++++++++++++++++++++++++++++++++++++++++++-- op_inspection_dialog.mli | 4 +- slave.ml | 19 +++++ slave.mli | 4 ++ slave_types.ml | 1 + slave_types.mli | 1 + 7 files changed, 205 insertions(+), 11 deletions(-) diff --git a/.depend b/.depend index 984a66e..af5fe13 100644 --- a/.depend +++ b/.depend @@ -40,8 +40,8 @@ op_file_information.cmi: filetree.cmi op_file_information.cmo: utils.cmi slave.cmi op_file_information.cmi op_file_information.cmx: utils.cmx slave.cmx op_file_information.cmi op_inspection_dialog.cmi: slave_types.cmi filetree.cmi -op_inspection_dialog.cmo: utils.cmi filetree.cmi op_inspection_dialog.cmi -op_inspection_dialog.cmx: utils.cmx filetree.cmx op_inspection_dialog.cmi +op_inspection_dialog.cmo: utils.cmi slave_types.cmi slave.cmi op_inspection_dialog.cmi +op_inspection_dialog.cmx: utils.cmx slave_types.cmx slave.cmx op_inspection_dialog.cmi op_view_file.cmi: filetree.cmi op_view_file.cmo: utils.cmi slave.cmi op_view_file.cmi op_view_file.cmx: utils.cmx slave.cmx op_view_file.cmi diff --git a/op_inspection_dialog.ml b/op_inspection_dialog.ml index f1b17da..2e84ded 100644 --- a/op_inspection_dialog.ml +++ b/op_inspection_dialog.ml @@ -20,18 +20,187 @@ open Printf open Utils -let inspection_dialog (tree : Filetree.tree) os = +module G = Guestfs + +let rec inspection_dialog tree os = debug "inspection dialog"; let title = "Inspection data" in - let dlg = GWindow.dialog ~title () in + let d = GWindow.dialog ~title () in + + (* Fill in the basic information. *) + let packing : GObj.widget -> unit = d#vbox#add in + let vbox = frame ~label:"Basic information" ~packing () in + let tbl = GPack.table ~columns:4 ~rows:1 ~packing:vbox#add () in + tbl#set_col_spacings 8; + tbl#set_row_spacings 8; + + wide tbl 0 "Product name: " os.Slave_types.insp_product_name; + wide tbl 1 "Hostname: " os.Slave_types.insp_hostname; + + simple tbl 2 0 "OS type: " os.Slave_types.insp_type; + simple tbl 3 0 "Distro: " os.Slave_types.insp_distro; + simple tbl 4 0 "Version: " + (sprintf "%d.%d" + os.Slave_types.insp_major_version + os.Slave_types.insp_minor_version); + simple tbl 5 0 "Product variant: " os.Slave_types.insp_product_variant; + + simple tbl 2 2 "Root: " os.Slave_types.insp_root; + simple tbl 3 2 "Arch: " os.Slave_types.insp_arch; + simple tbl 4 2 "Package mgr: " os.Slave_types.insp_package_management; + simple tbl 5 2 "Package fmt: " os.Slave_types.insp_package_format; + + (match os.Slave_types.insp_windows_systemroot with + | None -> () + | Some systemroot -> + simple tbl 6 0 "%systemroot%: " systemroot + ); + (match os.Slave_types.insp_windows_current_control_set with + | None -> () + | Some ccs -> + simple tbl 6 2 "CurrentControlSet: " ccs + ); + + (* Applications. *) + let vbox = frame ~label:"Applications" ~packing:d#vbox#add () in + applications_view ~packing:vbox#add os; + + (* Mountpoints. *) + let vbox = frame ~label:"Mount points" ~packing:d#vbox#add () in + two_column_view ~title1:"Mount" ~title2:"Filesystem" + ~packing:vbox#add os.Slave_types.insp_mountpoints; - dlg#show (); + (* Filesystems. *) + let vbox = frame ~label:"Filesystems" ~packing:d#vbox#add () in + one_column_view ~title:"Filesystem" ~packing:vbox#add + (Array.to_list os.Slave_types.insp_filesystems); + + (* Drive mappings. *) + (match os.Slave_types.insp_drive_mappings with + | [] -> () + | mappings -> + let vbox = frame ~label:"Drives" ~packing:d#vbox#add () in + two_column_view ~title1:"Drive letter" ~title2:"Filesystem" + ~packing:vbox#add mappings + ); (* Make sure dialog is destroyed when the tree is cleared. *) - ignore ( + let sigid = tree#clear_tree ~callback:( fun () -> debug "inspection clear_tree -> destroy dialog"; - dlg#destroy () - ) - ) + d#destroy () + ) in + + let destroy_dialog () = + tree#disconnect sigid; + d#destroy () + in + + (* Add a close button. *) + let close_button = GButton.button ~label:"Close" + ~packing:d#action_area#add () in + ignore (close_button#connect#clicked ~callback:destroy_dialog); + + (* Destroy dialog when WM close button is pressed. *) + ignore (d#connect#destroy ~callback:destroy_dialog); + + d#show () + +(* Helper functions. *) +and frame ?label ?packing () = + let frame = GBin.frame ?label ?packing () in + GPack.vbox ~border_width:8 ~packing:frame#add () + +and simple tbl top left label text = + let markup = sprintf "%s" (markup_escape text) in + ignore (GMisc.label ~xalign:1. ~text:label + ~packing:(tbl#attach ~top ~left) ()); + let left = left + 1 in + ignore (GMisc.label ~xalign:0. ~markup ~packing:(tbl#attach ~top ~left) ()); + +and wide tbl top label text = + let markup = sprintf "%s" (markup_escape text) in + ignore (GMisc.label ~xalign:1. + ~text:label ~packing:(tbl#attach ~top ~left:0) ()); + ignore (GMisc.label ~xalign:0. + ~markup ~packing:(tbl#attach ~top ~left:1 ~right:4) ()); + +and one_column_view ~title ?packing data = + let model, c1 = GTree.store_of_list Gobject.Data.string data in + + let sw = + GBin.scrolled_window ?packing ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in + + let view = GTree.view ~model ~packing:sw#add () in + view#selection#set_mode `NONE; + + let renderer = GTree.cell_renderer_text [], ["text", c1] in + let vc = GTree.view_column ~title ~renderer () in + vc#set_resizable true; + ignore (view#append_column vc) + +and two_column_view ~title1 ~title2 ?packing data = + let cols = new GTree.column_list in + let c1 = cols#add Gobject.Data.string in + let c2 = cols#add Gobject.Data.string in + + let model = GTree.list_store cols in + List.iter ( + fun (d1, d2) -> + let row = model#append () in + model#set ~row ~column:c1 d1; + model#set ~row ~column:c2 d2 + ) data; + + let sw = + GBin.scrolled_window ?packing ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in + + let view = GTree.view ~model ~packing:sw#add () in + view#selection#set_mode `NONE; + + let renderer = GTree.cell_renderer_text [], ["text", c1] in + let vc = GTree.view_column ~title:title1 ~renderer () in + vc#set_resizable true; + ignore (view#append_column vc); + let renderer = GTree.cell_renderer_text [], ["text", c2] in + let vc = GTree.view_column ~title:title2 ~renderer () in + vc#set_resizable true; + ignore (view#append_column vc) + +(* Applications view: populated after a round-trip to the slave thread. *) +and applications_view ?packing os = + let cols = new GTree.column_list in + let name_col = cols#add Gobject.Data.string in + let version_col = cols#add Gobject.Data.string in + + let model = GTree.list_store cols in + + let sw = + GBin.scrolled_window ?packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in + + let view = GTree.view ~model ~height:150 ~packing:sw#add () in + view#selection#set_mode `NONE; + + let renderer = GTree.cell_renderer_text [], ["text", name_col] in + let vc = GTree.view_column ~title:"Name" ~renderer () in + vc#set_resizable true; + ignore (view#append_column vc); + let renderer = GTree.cell_renderer_text [], ["text", version_col] in + let vc = GTree.view_column ~title:"Version" ~renderer () in + vc#set_resizable true; + ignore (view#append_column vc); + + Slave.list_applications os + (when_applications_loaded model name_col version_col) + +and when_applications_loaded model name_col version_col apps = + Array.iter ( + fun { G.app_name = name; app_display_name = display_name; + app_version = version; app_release = release } -> + let name = if display_name <> "" then display_name else name in + let version = version ^ if release <> "" then "-"^release else "" in + let row = model#append () in + model#set ~row ~column:name_col name; + model#set ~row ~column:version_col version + ) apps diff --git a/op_inspection_dialog.mli b/op_inspection_dialog.mli index 9e9901c..1d2cb8a 100644 --- a/op_inspection_dialog.mli +++ b/op_inspection_dialog.mli @@ -19,8 +19,8 @@ (** Operating system inspection data dialog. *) val inspection_dialog : Filetree.tree -> Slave_types.inspection_os -> unit - (** [dialog tree os] creates a operating system inspection - dialog, displaying the inspection data from [os]. + (** [inspection_dialog tree os] creates a operating system + inspection dialog, displaying the inspection data from [os]. [tree] is passed here just so that we can register a signal to destroy the dialog when the tree is cleared. *) diff --git a/slave.ml b/slave.ml index 412d183..034bbdf 100644 --- a/slave.ml +++ b/slave.ml @@ -47,6 +47,7 @@ type command = | Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback | Download_file of source * string * string * bool * unit callback | File_information of source * string * string callback + | List_applications of inspection_os * G.application array callback | Open_domain of string * inspection_data callback | Open_images of (string * string option) list * inspection_data callback | Read_directory of source * string * direntry list callback @@ -73,6 +74,8 @@ let rec string_of_command = function (string_of_source src) remotefile localfile check | File_information (src, pathname, _) -> sprintf "File_information (%s, %s)" (string_of_source src) pathname + | List_applications (os, _) -> + sprintf "List_applications %s" os.insp_root | Open_domain (name, _) -> sprintf "Open_domain %s" name | Open_images (images, _) -> sprintf "Open_images %s" (string_of_images images) @@ -165,6 +168,8 @@ let download_file_if_not_exist ?fail src remotefile localfile cb = send_to_slave ?fail (Download_file (src, remotefile, localfile, true, cb)) let file_information ?fail src pathname cb = send_to_slave ?fail (File_information (src, pathname, cb)) +let list_applications ?fail os cb = + send_to_slave ?fail (List_applications (os, cb)) let open_domain ?fail name cb = send_to_slave ?fail (Open_domain (name, cb)) let open_images ?fail images cb = send_to_slave ?fail (Open_images (images, cb)) let read_directory ?fail src path cb = @@ -338,6 +343,19 @@ and execute_command = function status "Finished calculating file information for %s" pathname; callback_if_not_discarded cb r + | List_applications (os, cb) -> + status "Listing applications ..."; + + let g = get_g () in + let r = + with_mount_ro g (OS os) ( + fun () -> + g#inspect_list_applications os.insp_root + ) in + + status "Finished listing applications"; + callback_if_not_discarded cb r + | Open_domain (name, cb) -> status "Opening %s ..." name; @@ -561,6 +579,7 @@ and open_disk_images images cb = insp_package_format = g#inspect_get_package_format root; insp_package_management = g#inspect_get_package_management root; insp_product_name = g#inspect_get_product_name root; + insp_product_variant = g#inspect_get_product_variant root; insp_type = typ; insp_windows_current_control_set = windows_current_control_set; insp_windows_systemroot = windows_systemroot; diff --git a/slave.mli b/slave.mli index 57ce332..c1fdb04 100644 --- a/slave.mli +++ b/slave.mli @@ -113,6 +113,10 @@ val file_information : ?fail:exn callback -> Slave_types.source -> string -> str (** [file_information src pathname cb] calculates the file information of the file [pathname]. *) +val list_applications : ?fail:exn callback -> Slave_types.inspection_os -> Guestfs.application array callback -> unit + (** [list_applications os cb] lists the applications in the + guest using libguestfs inspection. *) + val open_domain : ?fail:exn callback -> string -> Slave_types.inspection_data callback -> unit (** [open_domain name cb] retrieves the list of block devices for the libvirt domain [name], creates a libguestfs handle, adds diff --git a/slave_types.ml b/slave_types.ml index ea6c75c..f6d2122 100644 --- a/slave_types.ml +++ b/slave_types.ml @@ -43,6 +43,7 @@ and inspection_os = { insp_package_format : string; insp_package_management : string; insp_product_name : string; + insp_product_variant : string; insp_type : string; insp_windows_current_control_set : string option; insp_windows_systemroot : string option; diff --git a/slave_types.mli b/slave_types.mli index ee897a5..fb24186 100644 --- a/slave_types.mli +++ b/slave_types.mli @@ -47,6 +47,7 @@ and inspection_os = { insp_package_format : string; insp_package_management : string; insp_product_name : string; + insp_product_variant : string; insp_type : string; insp_windows_current_control_set : string option; insp_windows_systemroot : string option; -- 1.8.3.1