filetree_markup.ml

   1 (* Guestfs Browser.
   2  * Copyright (C) 2010 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 ExtString
  20 open ExtList
  21 open Unix
  22
  23 open CamomileLibrary
  24 open Default.Camomile
  25
  26 open Utils
  27 open Filetree_type
  28
  29 open Printf
  30
  31 (* Base colours. XXX Should be configurable somewhere. *)
  32 let file_color = 0x20, 0x20, 0xff  (* regular file *)
  33 let dir_color = 0x80, 0x80, 0x20   (* directory *)
  34 let symlink_color = file_color     (* symlink *)
  35 let suid_color = 0x20, 0x20, 0x80  (* setuid bit set on regular file *)
  36 let suid_bgcolor = 0xff, 0xc0, 0xc0
  37 let sgid_color = suid_color        (* setgid bit set on regular file *)
  38 let sgid_bgcolor = suid_bgcolor
  39 let block_color = 0x00, 0x60, 0x60 (* block device *)
  40 let char_color = block_color       (* char device *)
  41 let fifo_color = 0x60, 0x00, 0x60  (* fifo *)
  42 let socket_color = fifo_color      (* socket *)
  43 let other_color = file_color       (* anything not one of the above *)
  44
  45 (* Mark up a filename for the name_col column.
  46  *
  47  * See also
  48  * http://library.gnome.org/devel/pango/stable/PangoMarkupFormat.html
  49  *)
  50 let rec markup_of_name ?(visited = false) direntry =
  51   let name = direntry.Slave.dent_name in
  52   let mode = direntry.Slave.dent_stat.Guestfs.mode in
  53   if is_directory mode then (           (* directory *)
  54     let fg = if not visited then normal dir_color else darken dir_color in
  55     sprintf "<span weight=\"bold\" fgcolor=\"%s\">%s</span>"
  56       fg (markup_escape name)
  57   )
  58   else if is_symlink mode then (        (* symlink *)
  59     let link = direntry.Slave.dent_link in
  60     let fg =
  61       if not visited then normal symlink_color else darken symlink_color in
  62     sprintf "<span style=\"italic\" fgcolor=\"%s\">%s</span> %s <span style=\"italic\" fgcolor=\"%s\">%s</span>"
  63       fg (markup_escape name) utf8_rarrow fg (markup_escape link)
  64   )
  65   else (                                (* not directory, not symlink *)
  66     let fg, bg =
  67       if is_regular_file mode then (
  68         if is_suid mode then suid_color, Some suid_bgcolor
  69         else if is_sgid mode then sgid_color, Some sgid_bgcolor
  70         else file_color, None
  71       )
  72       else if is_block mode then block_color, None
  73       else if is_char mode then char_color, None
  74       else if is_fifo mode then fifo_color, None
  75       else if is_socket mode then socket_color, None
  76       else other_color, None in
  77     let fg = if not visited then normal fg else darken fg in
  78     let bg =
  79       match bg with
  80       | Some bg -> sprintf " bgcolor=\"%s\"" (normal bg)
  81       | None -> "" in
  82     sprintf "<span fgcolor=\"%s\"%s>%s</span>"
  83       fg bg (markup_escape name)
  84   )
  85
  86 (* Mark up a registry key. *)
  87 and markup_of_regkey ?(visited = false) h node =
  88   let name = Hivex.node_name h node in
  89   let name = if name = "" then "@" else name in
  90   let fg = if not visited then normal dir_color else darken dir_color in
  91   sprintf "<span fgcolor=\"%s\">%s</span>" fg (markup_escape name)
  92
  93 (* Mark up a registry value. *)
  94 and markup_of_regvalue ?(visited = false) h value =
  95   debug "markup_of_regvalue";
  96   let k = Hivex.value_key h value in
  97   let t, v = Hivex.value_value h value in
  98
  99   (* Ignore long values. *)
 100   let len = String.length v in
 101   let v =
 102     if len >= 256 then
 103       sprintf "&lt;%d bytes not printed&gt;" len
 104     else (
 105       (* Deal as best we can with printing the value. *)
 106       match t with
 107       | Hivex.REG_NONE -> if v = "" then "" else markup_hex_data v
 108       | Hivex.REG_SZ -> markup_windows_string v
 109       | Hivex.REG_EXPAND_SZ -> markup_windows_string v
 110       | Hivex.REG_BINARY -> markup_hex_data v
 111       | Hivex.REG_DWORD ->
 112           if len = 4 then
 113             sprintf "%08lx" (i32_of_string_le v)
 114           else
 115             markup_hex_data v
 116       | Hivex.REG_DWORD_BIG_ENDIAN ->
 117           if len = 4 then
 118             sprintf "%08lx" (i32_of_string_be v)
 119           else
 120             markup_hex_data v
 121       | Hivex.REG_LINK -> markup_hex_data v
 122       | Hivex.REG_MULTI_SZ -> (* XXX could do better with this *)
 123           markup_hex_data v
 124       | Hivex.REG_RESOURCE_LIST -> markup_hex_data v
 125       | Hivex.REG_FULL_RESOURCE_DESCRIPTOR -> markup_hex_data v
 126       | Hivex.REG_RESOURCE_REQUIREMENTS_LIST -> markup_hex_data v
 127       | Hivex.REG_QWORD ->
 128           if len = 8 then
 129             sprintf "%016Lx" (i64_of_string_le v)
 130           else
 131             markup_hex_data v
 132       | Hivex.REG_UNKNOWN i32 -> markup_hex_data v
 133     ) in
 134
 135   let fg = if not visited then normal file_color else darken file_color in
 136   sprintf "<span fgcolor=\"%s\">%s</span>=<span fgcolor=\"%s\">%s</span>"
 137     fg (markup_escape k) fg v
 138
 139 (* Mark up registry value as hex data. *)
 140 and markup_hex_data v =
 141   let vs = String.explode v in
 142   let vs = List.mapi (
 143     fun i c ->
 144       sprintf "%s%02x" (if i mod 16 = 0 then "\n" else "") (int_of_char c)
 145   ) vs in
 146   String.concat "," vs
 147
 148 (* Best guess the format of the string and convert to UTF-8. *)
 149 and markup_windows_string v =
 150   let utf16le = CharEncoding.utf16le in
 151   let utf8 = CharEncoding.utf8 in
 152   try
 153     let v = CharEncoding.recode_string ~in_enc:utf16le ~out_enc:utf8 v in
 154     (* Registry strings include the final \0 so remove this if present. *)
 155     let len = UTF8.length v in
 156     let v =
 157       if len > 0 && UChar.code (UTF8.get v (len-1)) = 0 then
 158         String.sub v 0 (UTF8.last v)
 159       else
 160         v in
 161     markup_escape v
 162   with
 163   | CharEncoding.Malformed_code
 164   | CharEncoding.Out_of_range ->
 165       (* Fallback to displaying the string as hex. *)
 166       markup_hex_data v
 167
 168 and normal (r, g, b) =
 169   let r = if r < 0 then 0 else if r > 255 then 255 else r in
 170   let g = if g < 0 then 0 else if g > 255 then 255 else g in
 171   let b = if b < 0 then 0 else if b > 255 then 255 else b in
 172   sprintf "#%02x%02x%02x" r g b
 173
 174 and darken (r, g, b) =
 175   normal (r * 4 / 10, g * 4 / 10, b * 4 / 10)
 176
 177 (* Mark up mode. *)
 178 let markup_of_mode mode =
 179   let c =
 180     if is_socket mode then 's'
 181     else if is_symlink mode then 'l'
 182     else if is_regular_file mode then '-'
 183     else if is_block mode then 'b'
 184     else if is_directory mode then 'd'
 185     else if is_char mode then 'c'
 186     else if is_fifo mode then 'p' else '?' in
 187   let ru = if is_ru mode then 'r' else '-' in
 188   let wu = if is_wu mode then 'w' else '-' in
 189   let xu = if is_xu mode then 'x' else '-' in
 190   let rg = if is_rg mode then 'r' else '-' in
 191   let wg = if is_wg mode then 'w' else '-' in
 192   let xg = if is_xg mode then 'x' else '-' in
 193   let ro = if is_ro mode then 'r' else '-' in
 194   let wo = if is_wo mode then 'w' else '-' in
 195   let xo = if is_xo mode then 'x' else '-' in
 196   let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
 197
 198   let suid = is_suid mode in
 199   let sgid = is_sgid mode in
 200   let svtx = is_svtx mode in
 201   if suid then str.[3] <- 's';
 202   if sgid then str.[6] <- 's';
 203   if svtx then str.[9] <- 't';
 204
 205   "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
 206
 207 (* Mark up dates. *)
 208 let markup_of_date t =
 209   (* Guestfs gives us int64's, we want float which is OCaml's
 210    * equivalent of time_t.
 211    *)
 212   let t = Int64.to_float t in
 213
 214   let show_full_date () =
 215     let tm = localtime t in
 216     sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
 217       (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
 218       tm.tm_hour tm.tm_min tm.tm_sec
 219   in
 220
 221   (* How long ago? *)
 222   let now = time () in
 223   let ago = now -. t in
 224   if ago < 0. then (* future *)
 225     show_full_date ()
 226   else if ago < 60. then
 227     "<small>now</small>"
 228   else if ago < 60. *. 60. then
 229     sprintf "<small>%.0f minutes ago</small>" (ago /. 60.)
 230   else if ago < 60. *. 60. *. 24. then
 231     sprintf "<small>%.0f hours ago</small>" (ago /. 60. /. 60.)
 232   else if ago < 60. *. 60. *. 24. *. 28. then
 233     sprintf "<small>%.0f days ago</small>" (ago /. 60. /. 60. /. 24.)
 234   else
 235     show_full_date ()
 236
 237 (* Mark up file sizes. *)
 238 let markup_of_size bytes =
 239   sprintf "<small>%s</small>" (human_size bytes)
 240
 241 (* Mark up registry value types. *)
 242 let markup_of_regvaluetype h value =
 243   let t, _ = Hivex.value_value h value in
 244
 245   match t with
 246   | Hivex.REG_NONE -> "none(0)"
 247   | Hivex.REG_SZ -> "str(1)"
 248   | Hivex.REG_EXPAND_SZ -> "str(2)"
 249   | Hivex.REG_BINARY -> "hex(3)"
 250   | Hivex.REG_DWORD -> "dword(4)"
 251   | Hivex.REG_DWORD_BIG_ENDIAN -> "dword(5)"
 252   | Hivex.REG_LINK -> "link(6)"
 253   | Hivex.REG_MULTI_SZ -> "multi string (7)"
 254   | Hivex.REG_RESOURCE_LIST -> "resource list (8)"
 255   | Hivex.REG_FULL_RESOURCE_DESCRIPTOR -> "full resource descriptor (9)"
 256   | Hivex.REG_RESOURCE_REQUIREMENTS_LIST -> "resource requirements list (10)"
 257   | Hivex.REG_QWORD -> "qword (11)"
 258   | Hivex.REG_UNKNOWN i32 -> sprintf "type 0x%08lx" i32
 259
 260 (* Mark up registry value sizes. *)
 261 let markup_of_regvaluesize h value =
 262   let _, len = Hivex.value_type h value in
 263   sprintf "%d" len
 264
 265 (* This is a bit of a hack.  Ideally just setting 'visited' would
 266  * darken the colour when the cell was re-rendered.  However that would
 267  * mean we couldn't store other stuff in the name column.  Therefore,
 268  * repopulate the name column.
 269  *)
 270 let set_visited ({ model = model; name_col = name_col } as t) row =
 271   let hdata = get_hdata t row in
 272   if hdata.visited = false then (
 273     hdata.visited <- true;
 274     match hdata.content with
 275     | Directory direntry | File direntry ->
 276         debug "set_visited %s" direntry.Slave.dent_name;
 277         model#set ~row ~column:name_col
 278           (markup_of_name ~visited:true direntry)
 279     | RegKey node ->
 280         debug "set_visited RegKey";
 281         let h = Option.get hdata.hiveh in
 282         model#set ~row ~column:name_col
 283           (markup_of_regkey ~visited:true h node)
 284     | RegValue value ->
 285         debug "set_visited RegValue";
 286         let h = Option.get hdata.hiveh in
 287         model#set ~row ~column:name_col
 288           (markup_of_regvalue ~visited:true h value)
 289     | Loading | ErrorMessage _ | Info _ | Top _ | TopWinReg _ -> ()
 290   )