make colours user-configurable

Author: hannesm

README.md

@@ -114,7 +114,7 @@ a = away, d = do not disturb, x = extended away, _ = offline).
 
 A single contact is active, which can be modified by `PgUp/PdDown`.
 The active contact is shown in reversed foreground and background
-color.  Its chat content is displayed in the chat window.  Certain
+colour.  Its chat content is displayed in the chat window.  Certain
 commands and operations (such as sending a message) require an active
 contact.
 
@@ -170,20 +170,49 @@ Active keys:
 
 `/help` prints the available commands, `/help command` more detailed help of the given command.
 
-#### Colors
+#### Colours
+
+default foreground colours are:
+- Chat empty
+- GroupChat empty
+- Presence gray 18
+- Info gray 18
+- Warning yellow
+- Error red
+- Success green
+
+To customise, create a file `colours.sexp` in your config folder
+(`~/.config/ocaml-xmpp-client` unless `-f` is provided).  Sample content:
+```
+((Chat "empty")
+ (GroupChat "empty")
+ (Presence "gray 18")
+ (Info "gray 18")
+ (Warning "yellow")
+ (Error "red")
+ (Success "green"))
+```
+
+Available colours:
+- "empty",
+- "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white",
+- "lightblack", "lightred", "lightgreen", "lightyellow", "lightblue", "lightmagenta", "lightcyan", "lightwhite",
+- "gray <n>" (where n is in the range 0 and 23,
+- "rgb <r> <g> <b>" (where r, g, b in the range 0 and 5)
+
+frame: red means the active session is unencrypted, green encrypted
 
 contact list:
-- green frame and contact: OTR session established
-- red frame and contact: no OTR session
-- black: no active session exists
+- green contact: OTR session established
+- red contact: no OTR session
+- black/white: groupchat, offline, self
 
 horizontal line
 - red OTR fingerprint: not verified (use a second channel)
 - green OTR: key is verified
 
-status line
-- own jabber id in reverse colors: logging to disk is enabled for this contact
-- own jabber id in usual colors: no logging to disk for this contact
+logging (`/log on|off`):
+- jabber id in status line in reverse: logging is turned on
 
 ### FAQ
 

_tags

@@ -13,11 +13,13 @@ true : package(sexplib astring)
 <src/xmpp_callbacks.ml>: package(erm_xmpp lwt tls tls.lwt ptime)
 <src/xmpp_connection.ml>: package(erm_xmpp lwt tls tls.lwt)
 
-<cli/cli_support.ml>: package(uutf notty astring)
-<cli/cli_client.ml>: package(lwt otr notty erm_xmpp ptime ptime.clock.os)
-<cli/cli_input.ml>: package(notty lwt erm_xmpp otr)
-<cli/cli_commands.ml>: package(lwt otr erm_xmpp)
-<cli/cli_config.ml>: package(lwt nocrypto otr notty tls.lwt x509)
-<cli/cli_state.ml>: package(hex lwt nocrypto erm_xmpp tls.lwt x509)
+<cli/*>: package(notty lwt)
+<cli/cli_colour.ml>: package(astring)
+<cli/cli_support.ml>: package(uutf astring)
+<cli/cli_client.ml>: package(otr erm_xmpp ptime ptime.clock.os)
+<cli/cli_input.ml>: package(erm_xmpp otr)
+<cli/cli_commands.ml>: package(otr erm_xmpp)
+<cli/cli_config.ml>: package(nocrypto otr tls.lwt x509)
+<cli/cli_state.ml>: package(hex nocrypto erm_xmpp tls.lwt x509)
 
 <bin/jackline.{ml,byte,native}>: package(erm_xmpp hex lwt notty notty.lwt nocrypto otr sexplib tls tls.lwt ptime ptime.clock.os)

bin/jackline.ml

@@ -59,6 +59,11 @@ let start_client cfgdir debug unicode fd_gui fd_nfy () =
         config
       | Some cfg -> Lwt.return cfg) >>= fun config ->
 
+  Cli_colour.init () ;
+  (Persistency.load_colours cfgdir >|= function
+    | None -> ()
+    | Some colours -> Cli_colour.load colours) >>= fun () ->
+
   (match config.Xconfig.password with
    | None -> Persistency.load_password cfgdir
    | Some x -> Lwt.return (Some x)) >>= (function
@@ -113,11 +118,14 @@ let start_client cfgdir debug unicode fd_gui fd_nfy () =
   let connect_mvar = Cli_state.Connect.connect_me config ui_mvar state_mvar users in
   let state = Cli_state.empty_state cfgdir config users connect_mvar state_mvar in
 
-  let greeting =
-    "multi user chat support: see you at /join jackline@conference.jabber.ccc.de (use ArrowUp key); \
-     type /help for help"
-  and sender = `Local (`Full myjid, "welcome to jackline " ^ Utils.version) in
-  Cli_state.add_status ~kind:`Info state sender greeting ;
+  let greetings = [
+    "welcome to jackline r" ^ Utils.version ;
+    "type /help for command list" ;
+    "* configurable colours! '((Presence \"cyan\") (Success \"lightgreen\"))' in your ~/.config/ocaml-xmpp-client/colours.sexp (see https://github.com/hannesm/jackline for details)" ;
+    "* improved MUC support: join&leave messages; autojoin on (re)connect; /rooms discovery" ]
+  and sender = `Local (`Full myjid,"")
+  in
+  List.iter (Cli_state.add_status ~kind:`Info state sender) greetings ;
 
   let us = Contact.fold (fun _ v acc -> v :: acc) users [] in
 

cli/cli_client.ml

@@ -13,13 +13,6 @@ let print_time ~now ~tz_offset_s timestamp =
   else
     Printf.sprintf "%02d-%02d %02d:%02d " m d hh mm
 
-let st_to_a = function
-  | `Chat | `GroupChat -> A.empty
-  | `Presence | `Info -> A.(fg (gray 18))
-  | `Warning -> A.(fg yellow)
-  | `Error -> A.(fg red)
-  | `Success -> A.(fg green)
-
 let format_log tz_offset_s now log =
   let { User.direction ; timestamp ; message ; kind ; _ } = log in
   let time = print_time ~now ~tz_offset_s timestamp in
@@ -29,7 +22,7 @@ let format_log tz_offset_s now log =
     | `Local (_, x) -> "* " ^ x ^ " *"
     | `To _ -> ">>>"
   in
-  (st_to_a kind, time ^ from ^ " " ^ message)
+  (Cli_colour.kind kind, time ^ from ^ " " ^ message)
 
 let format_message tz_offset_s now self buddy resource { User.direction ; encrypted ; received ; timestamp ; message ; kind ; _ } =
   let time = print_time ~now ~tz_offset_s timestamp
@@ -75,11 +68,11 @@ let format_message tz_offset_s now self buddy resource { User.direction ; encryp
       (style, r ^ pre)
   and to_style st =
     match st, kind with
-    | `Default, x -> st_to_a x
+    | `Default, x -> Cli_colour.kind x
     | `Highlight, `Chat | `Highlight, `GroupChat -> A.(st bold)
-    | `Highlight, x -> st_to_a x
+    | `Highlight, x -> Cli_colour.kind x
     | `Underline, `Chat | `Underline, `GroupChat -> A.(st underline)
-    | `Underline, x -> A.(st underline ++ st_to_a x)
+    | `Underline, x -> A.(st underline ++ Cli_colour.kind x)
   in
   let p, msg =
     if String.length message >= 3 && String.sub message 0 3 = "/me" then
@@ -103,8 +96,8 @@ let format_message tz_offset_s now self buddy resource { User.direction ; encryp
 
 let buddy_to_color = function
   | `Default -> A.empty
-  | `Good -> A.(fg green)
-  | `Bad -> A.(fg red)
+  | `Good -> Cli_colour.kind `Success
+  | `Bad -> Cli_colour.kind `Error
 
 let format_buddy state width s contact resource =
   let jid = Contact.jid contact resource in
@@ -211,7 +204,7 @@ let horizontal_line buddy resource a scrollback width =
 
 let status_line self mysession notify log a width =
   let a = A.(a ++ st bold) in
-  let notify = if notify then I.string A.(a ++ st blink ++ fg cyan) "##" else Char.hdash a 2
+  let notify = if notify then I.string A.(a ++ st blink ++ Cli_colour.kind `Warning) "##" else Char.hdash a 2
   and jid =
     let data = User.userid self mysession
     and a' = if log then A.(st reverse) else a
@@ -287,8 +280,8 @@ let render_state (width, height) state =
           let input = char_list_to_str pre in
           ( match Cli_commands.completion state input with
             | [] -> I.empty
-            | [x] -> I.string A.(fg (gray 18)) x
-            | xs -> I.string A.(fg (gray 18)) (String.concat "|" xs) )
+            | [x] -> I.string (Cli_colour.kind `Info) x
+            | xs -> I.string (Cli_colour.kind `Info) (String.concat "|" xs) )
         | _ -> iinp2
       in
       v_center iinp r width
@@ -386,7 +379,7 @@ let rec loop term size redrawer mvar input_mvar state =
         try
           render_state size state
         with e ->
-          let e = A.(fg red), (Printexc.to_string e)
+          let e = Cli_colour.kind `Error, (Printexc.to_string e)
           and note =
             "While trying to render the UI.  Try to scroll to another buddy \
              (Page Up/Down), switch rendering of buddy list (F12), or clear \

cli/cli_colour.ml

@@ -0,0 +1,93 @@
+open Notty
+open Astring
+
+module OrderedKind = struct
+  type t = User.chatkind
+
+  let compare (a : [< t]) (b : [< t]) = match a, b with
+    | `Chat, `Chat -> 0
+    | `GroupChat, `GroupChat -> 0
+    | `Presence, `Presence -> 0
+    | `Info, `Info -> 0
+    | `Warning, `Warning -> 0
+    | `Error, `Error -> 0
+    | `Success, `Success -> 0
+    | `Chat, _ -> 1
+    | _, `Chat -> -1
+    | `GroupChat, _ -> 1
+    | _, `GroupChat -> -1
+    | `Presence, _ -> 1
+    | _, `Presence -> -1
+    | `Info, _ -> 1
+    | _, `Info -> -1
+    | `Warning, _ -> 1
+    | _, `Warning -> -1
+    | `Error, _ -> 1
+    | _, `Error -> -1
+end
+
+module M = Map.Make(OrderedKind)
+
+let c = ref M.empty
+
+let init () =
+  let m =
+    M.add `Presence A.(gray 18)
+      (M.add `Info A.(gray 18)
+         (M.add `Warning A.yellow
+            (M.add `Error A.red
+               (M.add `Success A.green M.empty))))
+  in
+  c := m
+
+let parse_value =
+  let open A in
+  function
+  | "empty" -> None
+  | x -> Some (match x with
+  | "black" -> Some black
+  | "red" -> Some red
+  | "green" -> Some green
+  | "yellow" -> Some yellow
+  | "blue" -> Some blue
+  | "magenta" -> Some magenta
+  | "cyan" -> Some cyan
+  | "white" -> Some white
+  | "lightblack" -> Some lightblack
+  | "lightred" -> Some lightred
+  | "lightgreen" -> Some lightgreen
+  | "lightyellow" -> Some lightyellow
+  | "lightblue" -> Some lightblue
+  | "lightmagenta" -> Some lightmagenta
+  | "lightcyan" -> Some lightcyan
+  | "lightwhite" -> Some lightwhite
+  | x when String.is_prefix ~affix:"gray" x ->
+    (match String.cut ~sep:" " x with
+     | None -> None
+     | Some (_, i) -> match String.to_int i with
+       | Some x when x >= 0 && x <= 23 -> Some (gray x)
+       | _ -> None)
+  | x when String.is_prefix ~affix:"rgb" x ->
+    (match String.cuts ~sep:" " x with
+     | _::xs when List.length xs = 3 ->
+       (match
+          List.filter
+            (function None -> false | Some _ -> true)
+            (List.map String.to_int xs)
+        with
+        | Some r::Some g::Some b::[] when r >= 0 && r <= 5 && g >= 0 && g <= 5 && b >= 0 && b <= 5 ->
+          Some (rgb ~r ~g ~b)
+        | _ -> None)
+     | _ -> None)
+  | _ -> None)
+
+let load_c (kind, value) =
+  match parse_value value with
+  | None -> c := (M.remove kind !c)
+  | Some None -> invalid_arg ("couldn't parse your colour for " ^ User.chatkind_to_string kind ^ ": " ^ value)
+  | Some (Some col) -> c := (M.add kind col !c)
+
+let load = List.iter load_c
+
+let kind k = try A.fg (M.find k !c) with Not_found -> A.empty
+

src/persistency.ml

@@ -77,6 +77,7 @@ let write dir filename buf =
   Lwt.return ()
 
 let config = "config.sexp"
+let colours = "colours.sexp"
 let users = "users.sexp"
 
 let maybe_create_dir dir =
@@ -103,6 +104,12 @@ let load_config load_dsa cfg =
     Some (Xconfig.load_config (Some dsa) x)
   | None   -> Lwt.return_none
 
+
+let load_colours cfg =
+  read cfg colours >|= function
+  | Some x -> Some (Sexplib.Conv.(list_of_sexp (pair_of_sexp User.chatkind_of_sexp string_of_sexp)) (Sexplib.Sexp.of_string x))
+  | None   -> None
+
 let dump_user cfgdir user =
   user_dir cfgdir >>= fun userdir ->
   let out = Xjid.bare_jid_to_string (Contact.bare user) in

src/user.ml

@@ -216,6 +216,9 @@ type chatkind = [
   | `Success
 ] [@@deriving sexp]
 
+let chatkind_to_string k =
+  Sexplib.Sexp.to_string (sexp_of_chatkind k)
+
 type message = {
   direction  : direction ;
   encrypted  : bool ;

src/user.mli

@@ -99,6 +99,7 @@ type chatkind = [
 
 val chatkind_of_sexp : Sexplib.Type.t -> chatkind
 val sexp_of_chatkind : chatkind -> Sexplib.Type.t
+val chatkind_to_string : chatkind -> string
 
 type message = {
   direction  : direction ;