op_inspection_dialog.ml

   1 (* Guestfs Browser.
   2  * Copyright (C) 2011 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License along
  15  * with this program; if not, write to the Free Software Foundation, Inc.,
  16  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17  *)
  18
  19 open Printf
  20
  21 open Utils
  22 open Slave_types
  23
  24 module G = Guestfs
  25
  26 let rec inspection_dialog tree os =
  27   debug "inspection dialog";
  28   let title = "Operating system information" in
  29   let d = GWindow.dialog ~width:500 ~height:600 ~title () in
  30
  31   let nb = GPack.notebook ~packing:d#vbox#add () in
  32
  33   (* Fill in the basic information. *)
  34   let vbox = tab "Basic information" nb in
  35   let tbl = GPack.table ~columns:4 ~rows:1 ~packing:vbox#add () in
  36   tbl#set_col_spacings 8;
  37   tbl#set_row_spacings 8;
  38
  39   wide tbl 0 "Product name: " os.insp_product_name;
  40   wide tbl 1 "Hostname: " os.insp_hostname;
  41
  42   simple tbl 2 0 "OS type: " os.insp_type;
  43   simple tbl 3 0 "Distro: " os.insp_distro;
  44   simple tbl 4 0 "Version: "
  45     (sprintf "%d.%d"
  46        os.insp_major_version
  47        os.insp_minor_version);
  48   simple tbl 5 0 "Product variant: " os.insp_product_variant;
  49
  50   simple tbl 2 2 "Root: " os.insp_root;
  51   simple tbl 3 2 "Arch: " os.insp_arch;
  52   simple tbl 4 2 "Package mgr: " os.insp_package_management;
  53   simple tbl 5 2 "Package fmt: " os.insp_package_format;
  54
  55   (match os.insp_windows_systemroot with
  56    | None -> ()
  57    | Some systemroot ->
  58        simple tbl 6 0 "%systemroot%: " systemroot
  59   );
  60   (match os.insp_windows_current_control_set with
  61    | None -> ()
  62    | Some ccs ->
  63        simple tbl 6 2 "CurrentControlSet: " ccs
  64   );
  65
  66   (* Applications. *)
  67   let vbox = tab "Applications" nb in
  68   applications_view ~packing:vbox#add os;
  69
  70   (* Mountpoints. *)
  71   let vbox = tab "Mount points" nb in
  72   two_column_view ~title1:"Mount" ~title2:"Filesystem"
  73     ~packing:vbox#add os.insp_mountpoints;
  74
  75   (* Filesystems. *)
  76   let vbox = tab "Filesystems" nb in
  77   one_column_view  ~title:"Filesystem" ~packing:vbox#add
  78     (Array.to_list os.insp_filesystems);
  79
  80   (* Drive mappings. *)
  81   (match os.insp_drive_mappings with
  82    | [] -> ()
  83    | mappings ->
  84        let vbox = tab "Drive letters" nb in
  85        two_column_view ~title1:"Drive letter" ~title2:"Filesystem"
  86          ~packing:vbox#add mappings
  87   );
  88
  89   (* Make sure dialog is destroyed when the tree is cleared. *)
  90   let sigid =
  91     tree#clear_tree ~callback:(
  92       fun () ->
  93         debug "inspection clear_tree -> destroy dialog";
  94         d#destroy ()
  95     ) in
  96
  97   let destroy_dialog () =
  98     tree#disconnect sigid;
  99     d#destroy ()
 100   in
 101
 102   (* Add a close button. *)
 103   let close_button = GButton.button ~label:"Close"
 104     ~packing:d#action_area#add () in
 105   ignore (close_button#connect#clicked ~callback:destroy_dialog);
 106
 107   (* Destroy dialog when WM close button is pressed. *)
 108   ignore (d#connect#destroy ~callback:destroy_dialog);
 109
 110   d#show ()
 111
 112 (* Helper functions. *)
 113 and tab text nb =
 114   let vbox = GPack.vbox ~border_width:8 () in
 115   let tab_label = (GMisc.label ~text () :> GObj.widget) in
 116   ignore (nb#append_page ~tab_label (vbox :> GObj.widget));
 117   vbox
 118
 119 and simple tbl top left label text =
 120   let markup = sprintf "<b>%s</b>" (markup_escape text) in
 121   ignore (GMisc.label ~xalign:1. ~text:label
 122             ~packing:(tbl#attach ~top ~left) ());
 123   let left = left + 1 in
 124   ignore (GMisc.label ~xalign:0. ~markup ~packing:(tbl#attach ~top ~left) ());
 125
 126 and wide tbl top label text =
 127   let markup = sprintf "<b>%s</b>" (markup_escape text) in
 128   ignore (GMisc.label ~xalign:1.
 129             ~text:label ~packing:(tbl#attach ~top ~left:0) ());
 130   ignore (GMisc.label ~xalign:0.
 131             ~markup ~packing:(tbl#attach ~top ~left:1 ~right:4) ());
 132
 133 and one_column_view ~title ?packing data =
 134   let data = List.sort compare data in
 135   let model, c1 = GTree.store_of_list Gobject.Data.string data in
 136
 137   let sw =
 138     GBin.scrolled_window ?packing ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
 139
 140   let view = GTree.view ~model ~packing:sw#add () in
 141   view#selection#set_mode `NONE;
 142
 143   let renderer = GTree.cell_renderer_text [], ["text", c1] in
 144   let vc = GTree.view_column ~title ~renderer () in
 145   vc#set_resizable true;
 146   ignore (view#append_column vc)
 147
 148 and two_column_view ~title1 ~title2 ?packing data =
 149   let data = List.sort compare data in
 150
 151   let cols = new GTree.column_list in
 152   let c1 = cols#add Gobject.Data.string in
 153   let c2 = cols#add Gobject.Data.string in
 154
 155   let model = GTree.list_store cols in
 156   List.iter (
 157     fun (d1, d2) ->
 158       let row = model#append () in
 159       model#set ~row ~column:c1 d1;
 160       model#set ~row ~column:c2 d2
 161   ) data;
 162
 163   let sw =
 164     GBin.scrolled_window ?packing ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
 165
 166   let view = GTree.view ~model ~packing:sw#add () in
 167   view#selection#set_mode `NONE;
 168
 169   let renderer = GTree.cell_renderer_text [], ["text", c1] in
 170   let vc = GTree.view_column ~title:title1 ~renderer () in
 171   vc#set_resizable true;
 172   ignore (view#append_column vc);
 173   let renderer = GTree.cell_renderer_text [], ["text", c2] in
 174   let vc = GTree.view_column ~title:title2 ~renderer () in
 175   vc#set_resizable true;
 176   ignore (view#append_column vc)
 177
 178 (* Applications view: populated after a round-trip to the slave thread. *)
 179 and applications_view ?packing os =
 180   let cols = new GTree.column_list in
 181   let name_col = cols#add Gobject.Data.string in
 182   let version_col = cols#add Gobject.Data.string in
 183
 184   let model = GTree.list_store cols in
 185
 186   let sw =
 187     GBin.scrolled_window ?packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in
 188
 189   let view = GTree.view ~model ~packing:sw#add () in
 190   view#selection#set_mode `NONE;
 191
 192   let renderer = GTree.cell_renderer_text [], ["text", name_col] in
 193   let vc = GTree.view_column ~title:"Name" ~renderer () in
 194   vc#set_resizable true;
 195   ignore (view#append_column vc);
 196   let renderer = GTree.cell_renderer_text [], ["text", version_col] in
 197   let vc = GTree.view_column ~title:"Version" ~renderer () in
 198   vc#set_resizable true;
 199   ignore (view#append_column vc);
 200
 201   Slave.list_applications os
 202     (when_applications_loaded model name_col version_col)
 203
 204 and when_applications_loaded model name_col version_col apps =
 205   Array.iter (
 206     fun { G.app_name = name; app_display_name = display_name;
 207           app_version = version; app_release = release } ->
 208       let name = if display_name <> "" then display_name else name in
 209       let version = version ^ if release <> "" then "-"^release else "" in
 210       let row = model#append () in
 211       model#set ~row ~column:name_col name;
 212       model#set ~row ~column:version_col version
 213   ) apps