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 Utils
  24 open Slave_types
  25
  26 open Printf
  27
  28 (* Base colours. XXX Should be configurable somewhere. *)
  29 let file_color = 0x20, 0x20, 0xff  (* regular file *)
  30 let dir_color = 0x80, 0x80, 0x20   (* directory *)
  31 let symlink_color = file_color     (* symlink *)
  32 let suid_color = 0x20, 0x20, 0x80  (* setuid bit set on regular file *)
  33 let suid_bgcolor = 0xff, 0xc0, 0xc0
  34 let sgid_color = suid_color        (* setgid bit set on regular file *)
  35 let sgid_bgcolor = suid_bgcolor
  36 let block_color = 0x00, 0x60, 0x60 (* block device *)
  37 let char_color = block_color       (* char device *)
  38 let fifo_color = 0x60, 0x00, 0x60  (* fifo *)
  39 let socket_color = fifo_color      (* socket *)
  40 let other_color = file_color       (* anything not one of the above *)
  41
  42 (* Mark up a filename for the name_col column.
  43  *
  44  * See also
  45  * http://library.gnome.org/devel/pango/stable/PangoMarkupFormat.html
  46  *)
  47 let rec markup_of_name ?(visited = false) direntry =
  48   let name = direntry.dent_name in
  49   let mode = direntry.dent_stat.Guestfs.mode in
  50   if is_directory mode then (           (* directory *)
  51     let fg = if not visited then normal dir_color else darken dir_color in
  52     sprintf "<span weight=\"bold\" fgcolor=\"%s\">%s</span>"
  53       fg (markup_escape name)
  54   )
  55   else if is_symlink mode then (        (* symlink *)
  56     let link = direntry.dent_link in
  57     let fg =
  58       if not visited then normal symlink_color else darken symlink_color in
  59     sprintf "<span style=\"italic\" fgcolor=\"%s\">%s</span> %s <span style=\"italic\" fgcolor=\"%s\">%s</span>"
  60       fg (markup_escape name) utf8_rarrow fg (markup_escape link)
  61   )
  62   else (                                (* not directory, not symlink *)
  63     let fg, bg =
  64       if is_regular_file mode then (
  65         if is_suid mode then suid_color, Some suid_bgcolor
  66         else if is_sgid mode then sgid_color, Some sgid_bgcolor
  67         else file_color, None
  68       )
  69       else if is_block mode then block_color, None
  70       else if is_char mode then char_color, None
  71       else if is_fifo mode then fifo_color, None
  72       else if is_socket mode then socket_color, None
  73       else other_color, None in
  74     let fg = if not visited then normal fg else darken fg in
  75     let bg =
  76       match bg with
  77       | Some bg -> sprintf " bgcolor=\"%s\"" (normal bg)
  78       | None -> "" in
  79     sprintf "<span fgcolor=\"%s\"%s>%s</span>"
  80       fg bg (markup_escape name)
  81   )
  82
  83 (* Mark up a registry key. *)
  84 and markup_of_regkey ?(visited = false) h node =
  85   let name = Hivex.node_name h node in
  86   let fg = if not visited then normal dir_color else darken dir_color in
  87   sprintf "<span fgcolor=\"%s\">%s</span>" fg (markup_escape name)
  88
  89 (* Mark up a registry value. *)
  90 and markup_of_regvalue ?(visited = false) h value =
  91   let k = Hivex.value_key h value in
  92   let k = if k = "" then "@" else k in
  93   let t, v = Hivex.value_value h value in
  94
  95   (* Ignore long values. *)
  96   let len = String.length v in
  97   let v =
  98     if len >= 512 then sprintf "&lt;%d bytes not printed&gt;" len
  99     else markup_escape (printable_hivex_value ~split_long_lines:true t v) in
 100
 101   let fg = if not visited then normal file_color else darken file_color in
 102   sprintf "<span fgcolor=\"%s\">%s</span>=<span fgcolor=\"%s\">%s</span>"
 103     fg (markup_escape k) fg v
 104
 105 and normal (r, g, b) =
 106   let r = if r < 0 then 0 else if r > 255 then 255 else r in
 107   let g = if g < 0 then 0 else if g > 255 then 255 else g in
 108   let b = if b < 0 then 0 else if b > 255 then 255 else b in
 109   sprintf "#%02x%02x%02x" r g b
 110
 111 and darken (r, g, b) =
 112   normal (r * 4 / 10, g * 4 / 10, b * 4 / 10)
 113
 114 (* Mark up mode. *)
 115 let markup_of_mode mode =
 116   let c =
 117     if is_socket mode then 's'
 118     else if is_symlink mode then 'l'
 119     else if is_regular_file mode then '-'
 120     else if is_block mode then 'b'
 121     else if is_directory mode then 'd'
 122     else if is_char mode then 'c'
 123     else if is_fifo mode then 'p' else '?' in
 124   let ru = if is_ru mode then 'r' else '-' in
 125   let wu = if is_wu mode then 'w' else '-' in
 126   let xu = if is_xu mode then 'x' else '-' in
 127   let rg = if is_rg mode then 'r' else '-' in
 128   let wg = if is_wg mode then 'w' else '-' in
 129   let xg = if is_xg mode then 'x' else '-' in
 130   let ro = if is_ro mode then 'r' else '-' in
 131   let wo = if is_wo mode then 'w' else '-' in
 132   let xo = if is_xo mode then 'x' else '-' in
 133   let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
 134
 135   let suid = is_suid mode in
 136   let sgid = is_sgid mode in
 137   let svtx = is_svtx mode in
 138   if suid then str.[3] <- 's';
 139   if sgid then str.[6] <- 's';
 140   if svtx then str.[9] <- 't';
 141
 142   "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
 143
 144 (* Mark up dates. *)
 145 let markup_of_date t =
 146   (* Guestfs gives us int64's, we want float which is OCaml's
 147    * equivalent of time_t.
 148    *)
 149   let t = Int64.to_float t in
 150
 151   let show_full_date () =
 152     let tm = localtime t in
 153     sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
 154       (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
 155       tm.tm_hour tm.tm_min tm.tm_sec
 156   in
 157
 158   (* How long ago? *)
 159   let now = time () in
 160   let ago = now -. t in
 161   if ago < 0. then (* future *)
 162     show_full_date ()
 163   else if ago < 60. then
 164     "<small>now</small>"
 165   else if ago < 60. *. 60. then
 166     sprintf "<small>%.0f minutes ago</small>" (ago /. 60.)
 167   else if ago < 60. *. 60. *. 24. then
 168     sprintf "<small>%.0f hours ago</small>" (ago /. 60. /. 60.)
 169   else if ago < 60. *. 60. *. 24. *. 28. then
 170     sprintf "<small>%.0f days ago</small>" (ago /. 60. /. 60. /. 24.)
 171   else
 172     show_full_date ()
 173
 174 (* Mark up file sizes. *)
 175 let markup_of_size bytes =
 176   sprintf "<small>%s</small>" (human_size bytes)
 177
 178 (* Mark up registry value types. *)
 179 let markup_of_regvaluetype h value =
 180   let t, _ = Hivex.value_value h value in
 181
 182   match t with
 183   | Hivex.REG_NONE -> "none(0)"
 184   | Hivex.REG_SZ -> "str(1)"
 185   | Hivex.REG_EXPAND_SZ -> "str(2)"
 186   | Hivex.REG_BINARY -> "hex(3)"
 187   | Hivex.REG_DWORD -> "dword(4)"
 188   | Hivex.REG_DWORD_BIG_ENDIAN -> "dword(5)"
 189   | Hivex.REG_LINK -> "link(6)"
 190   | Hivex.REG_MULTI_SZ -> "multi string (7)"
 191   | Hivex.REG_RESOURCE_LIST -> "resource list (8)"
 192   | Hivex.REG_FULL_RESOURCE_DESCRIPTOR -> "full resource descriptor (9)"
 193   | Hivex.REG_RESOURCE_REQUIREMENTS_LIST -> "resource requirements list (10)"
 194   | Hivex.REG_QWORD -> "qword (11)"
 195   | Hivex.REG_UNKNOWN i32 -> sprintf "type 0x%08lx" i32
 196
 197 (* Mark up registry value sizes. *)
 198 let markup_of_regvaluesize h value =
 199   let _, len = Hivex.value_type h value in
 200   sprintf "%d" len