(*************************************************************************)
(* This program is free software: you can redistribute it and/or modify  *)
(* it under the terms of the version 3 of the GNU General Public License *)
(* as published by the Free Software Foundation.                         *)
(*                                                                       *)
(* This program is distributed in the hope that it will be useful, but   *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU      *)
(* General Public License for more details.                              *)
(*                                                                       *)
(* You should have received a copy of the GNU General Public License     *)
(* along with this program. If not, see <http://www.gnu.org/licenses/>.  *)
(*                                                                       *)
(* Written and (C) by Francois Fleuret                                   *)
(* Contact <francois.fleuret@idiap.ch> for comments & bug reports        *)
(*************************************************************************)

open Connection;;

(* I removed all the dcc stuff between v0.25 and v0.5 because it was a
   biiiig pile of crap. Feel free to write it ! *)

let version = "IRCML v0.5";;

let term_bold = ref ""
and term_underline = ref ""
and term_inverse = ref ""
and term_reset = ref "";;

(*****************************************************************************)
(*                                Various stuff                              *)
(*****************************************************************************)

let keys h = Hashtbl.fold (fun key data accu -> key :: accu) h []

let verbose = ref false;;

(* Return the element after the given one, or the first of the list if
   the given one is the last *)

let circular_succ =
  fun x l ->
    let rec next_rec x = function
        [] -> raise Not_found
      | h::t -> if h = x then List.hd t else next_rec x t
    in try next_rec x l with Failure(e) -> List.hd l;;

let string_of_size size =
  if size > 1048576 then (string_of_int (size / 1048576))^"Mb"
  else if size > 1024 then (string_of_int (size / 1024))^"Kb"
  else (string_of_int size) ^ "b";;

let duration_of_seconds duration =
  (if duration >= 3600 then (string_of_int (duration/3600))^"h" else "") ^
    (if (duration mod 3600) >= 60 then (string_of_int ((duration mod 3600)/60))^"min" else "") ^
    (if (duration mod 60) > 0 then (string_of_int (duration mod 60))^"s" else "");;

(*****************************************************************************)
(*                             The global variables                          *)
(*****************************************************************************)

type user_status = { mutable operator: bool }
let string_of_user = fun u -> (if u.operator then "@" else "")

type channel = { name: string; people: (string, user_status) Hashtbl.t ; modes: (char, string) Hashtbl.t };;

let ssfe = ref false

and my_host = ref ""

and desired_nick = ref "b0z0"
and desired_server = ref "localhost"
and desired_port = ref 6667

and current_nick = ref ""
and (current_modes:  (char, string) Hashtbl.t) = Hashtbl.create 10
and default_channel = ref ""

and login = ref "c4mlp0w4"
and name = ref ("Using " ^ version ^ ", the light IRC client in CAML")

and alive = ref true;;

(* Print something with a 'header character' à la sirc                       *)
(* '<' Leaving channel (part, kick, signoff, etc.)                           *)
(* '>' Joining a channel                                                     *)
(* 'E' Error                                                                 *)
(* 'I' Information                                                           *)
(* 'X' Internal error, should never meet one                                 *)
let printh h s = output_string Pervasives.stdout
  begin
    match h with
        "E" -> (!term_bold ^ "*" ^ h ^ "*" ^ " " ^ s ^ !term_reset ^ "\n")
      | _   -> (!term_bold ^ "*" ^ h ^ "*" ^ !term_reset ^ " " ^ s ^ "\n")
  end;;

(* Simply print something in the console *)
let print s = output_string Pervasives.stdout (s ^ "\n");;

type ssfe_cmd = Status of string | Tabulable of string;;

let current_status = ref "";;

let tell_ssfe x =
  if !ssfe then begin
    match x with
        Status(s) -> if not (s = !current_status) then (current_status := s; print ("`#ssfe#s" ^ s))
      | Tabulable(s) -> print ("`#ssfe#t" ^ s)
  end;;

(*****************************************************************************)
(*                      Command line parameter parsing                       *)
(*****************************************************************************)

Arg.parse [ ("-nick",   Arg.String(fun n -> desired_nick := n),   "Set the desired nick");
            ("-server", Arg.String(fun s -> desired_server := s), "Set the desired server");
            ("-port",   Arg.Int(fun p -> desired_port := p),      "Set the desired port");
            ("-login",  Arg.String(fun s -> login := s),          "Set the login");
            ("-name",   Arg.String(fun s -> name := s),           "Set the name") ]
  (fun s -> ()) "Unknown option";;

(*****************************************************************************)
(*                       The connection with the server                      *)
(*****************************************************************************)

type connection =
    Established of Unix.file_descr
  | Broken;;

let last_server_msg = ref 0;;

let server_connection = ref Broken;;

(* This is the list of file descriptors active for reading. Each one
   corresponds to a reader which will be called when something is
   readable and a exception-handler, called if the connection is lost,
   with the reason *)

type fd_machine = { reader: unit -> unit; error_handler: string -> unit };;

let (fd_active: (Unix.file_descr, fd_machine) Hashtbl.t) = Hashtbl.create 10;;

(*****************************************************************************)
(*                        Handling of the channel list                       *)
(*****************************************************************************)

let (joined_channels: (string, channel) Hashtbl.t) = Hashtbl.create 10;;

let find_joined c = Hashtbl.find joined_channels (String.uppercase c)
and mem_joined c = Hashtbl.mem joined_channels (String.uppercase c)
and set_joined c x = Hashtbl.replace joined_channels (String.uppercase c) x
and remove_joined c = Hashtbl.remove joined_channels (String.uppercase c)
and same_channel c1 c2 = (String.uppercase c1) = (String.uppercase c2);;

let part_channel channel =
  remove_joined channel;
  if !default_channel = channel
  then match (keys joined_channels) with
      [] -> default_channel := ""; if not !ssfe then printh "I" "Not in a channel anymore"
    | c::t -> default_channel := c; printh "I" ("Talking to " ^ !default_channel ^ " now");;

(*****************************************************************************)
(* Takes a string and returns an array of strings corresponding to the       *)
(* tokens in the IRC protocole syntax. I.e. tokens are separated by white    *)
(* spaces except the tail which is after a ':'                               *)
(*****************************************************************************)

let (irc_tokenize: string -> string array) = fun s ->
  let l = (String.length s) in
  let rec irc_tokenize s n =
    if String.get s n == ':' then [String.sub s (n + 1) (l - n - 2)] else
      try
        let m = String.index_from s n ' ' in
        let h = String.sub s n (m - n) in
          h::irc_tokenize s (m+1)
      with
          Not_found -> if n < l then [String.sub s n (l - n - 1)] else []
  in
    (* Ignore the prefix if there is one *)
    if (String.get s 0) == ':' then
      let n = (String.index s ' ') in Array.of_list ((String.sub s 1 (n - 1))::(irc_tokenize s (n+1)))
    else Array.of_list (""::(irc_tokenize s 0));;

(* Function to split the "nick!login@host" *)

let (split_prefix: string -> string * string * string) = fun prefix ->
  let n1 = (String.index prefix '!') in
  let n2 = (String.index_from prefix n1 '@') in
    (String.sub prefix 0 n1,
     String.sub prefix (n1 + 1) (n2 - (n1 + 1)),
     String.sub prefix (n2 + 1) ((String.length prefix) - (n2 + 1)));;

(*****************************************************************************)
(*                             The aliases                                   *)
(*****************************************************************************)

let (cmd_aliases: (string, string) Hashtbl.t) = Hashtbl.create 100;;

List.iter (fun (a, b) -> Hashtbl.replace cmd_aliases a b) [
  ("J", "JOIN"); ("M", "MSG"); ("K", "KICK"); ("L", "CHANINFO");
  ("N", "NICK"); ("Q", "QUIT"); ("T", "TOPIC"); ("W", "WHOIS");
  ("DC", "DISCONNECT"); ("S", "SERVER"); ("H", "HELP")
];;

(*****************************************************************************)
(*                     The managers will be filled later                     *)
(*****************************************************************************)

let (protocole_managers: (string, string array -> unit) Hashtbl.t) = Hashtbl.create 100;;
let (cmd_managers: (string, string * ((unit -> string) -> (unit -> string) -> unit)) Hashtbl.t) = Hashtbl.create 100;;
let (ctcp_managers: (string, (unit -> string) -> (unit -> string) -> string -> string -> unit) Hashtbl.t) = Hashtbl.create 10;;

(*****************************************************************************)
(*         The routines handling lines from the server or the user           *)
(*****************************************************************************)

let print_unknown_protocole = fun tokens ->
  let buffer = Buffer.create 100 in
    Buffer.add_string buffer "Unknown protocole";
    for i = 0 to ((Array.length tokens) - 1) do
      Buffer.add_string buffer (" " ^ (string_of_int i) ^ ":(" ^ tokens.(i) ^ ")");
    done;
    printh "X" (Buffer.contents buffer);;

let server_line_handler = fun line ->
  if !verbose then (print_string ("SERVER [" ^ line ^ "]\n"); flush stdout);
  last_server_msg := int_of_float (Unix.time ());
  let tokens = (irc_tokenize line) in
    try
      let f = Hashtbl.find protocole_managers tokens.(1) in
        try f tokens with Not_found -> printh "E" ("Protocole " ^ tokens.(1) ^ " raised Not_found!")
    with
        Not_found -> print_unknown_protocole tokens;;

let kill_server_connection error_message =
  match !server_connection with
      Established(fd) ->
        begin
          Hashtbl.remove fd_active fd;
          server_connection := Broken;
          printh "E" ("Connection lost (" ^ error_message ^ ")");
          default_channel := "";
          Hashtbl.clear joined_channels
        end
    | Broken -> exit 1;;

let tell_server line =
  match !server_connection with
      Established(fd) ->
        begin
          try
            if (Unix.write fd line 0 (String.length line)) <= 0 then kill_server_connection ("write error")
          with
              Unix.Unix_error(e, fname, fparam) -> kill_server_connection (fname ^ ": " ^ (Unix.error_message e))
        end
    | Broken -> printh "E" "No connection";;

let establish_connection () =
  match !server_connection with
      Established(_) -> printh "E" "Connection already established (try /DISCONNECT first)"
    | Broken ->
        printh "I" ("Attempting connection to " ^ !desired_server ^
                      ":" ^ (string_of_int !desired_port) ^
                      " with nick " ^ !desired_nick);
        try
          let fd = Connection.connect !desired_server !desired_port in
            begin
              match Unix.getsockname fd with
                  Unix.ADDR_INET(ai, _) -> my_host := Connection.dot_to_number (Unix.string_of_inet_addr ai)
                | _ -> printh "E" "Internal error #0";
            end;
            server_connection := Established(fd);
            Hashtbl.replace fd_active fd { reader = linizer fd server_line_handler; error_handler = kill_server_connection };
            tell_server ("USER " ^ !login ^ " caml rulez :" ^ !name ^ "\n");
            tell_server ("NICK " ^ !desired_nick ^ "\n");
            last_server_msg := int_of_float (Unix.time ());
            printh "I" ("Connection established, waiting for server checkings.");
        with
            Network_error(e) -> printh "E" ("Can not connect to host: " ^ e);;

let stdin_line_handler = fun line ->
  (*print_string ("STDIN  [" ^ line ^ "]\n"); flush stdout;*)
  if String.length line > 0 then
    match String.get line 0 with
        '/' ->
          begin
            let (cl_token, cl_tail) = tokenizer line ' ' in
            let cmd = String.uppercase (cl_token ()) in let cmd = String.sub cmd 1 ((String.length cmd) - 1) in
            let cmd = try Hashtbl.find cmd_aliases cmd with Not_found -> cmd in
              try
                let (_, f) = (Hashtbl.find cmd_managers cmd) in
                  begin
                    try
                      f cl_token cl_tail
                    with
                        Not_found -> printh "E" ("Command " ^ cmd ^ " raised Not_found!")
                  end
              with
                  Not_found -> printh "E" ("Unknown command '" ^ cmd ^ "'");
          end

      | '@' ->
          begin
            let (cl_token, cl_tail) = tokenizer line ' ' in
              match cl_token () with
                  "@ssfe@i" ->
                    begin
                      ssfe := true;
                      printh "I" "You are using ssfe";
                      term_bold := "";
                      term_underline := "";
                      term_inverse := "";
                      term_reset := "";
                    end
                | _ -> ()
          end

      | _ ->
          if !default_channel = ""
          then printh "E" "Not in a channel"
          else
            begin
              print ("<" ^ !current_nick ^ "> " ^ line);
              tell_server ("PRIVMSG " ^ !default_channel ^ " :" ^ line ^ "\n")
            end;;

let console_reader = linizer Unix.stdin stdin_line_handler
and console_error = fun error_message -> printh "E" ("Stdin error (" ^ error_message ^ ")"); exit 1 in
  Hashtbl.replace fd_active Unix.stdin { reader = console_reader; error_handler = console_error };;

(*****************************************************************************)
(*                         Functions to handle scripts                       *)
(*****************************************************************************)

Hashtbl.add cmd_managers
  "LOAD"
  begin
    "<module>: Loads the given bytecode object",
    fun token tail ->
      try
        let module_name = token () in
          printh "I" ("loading module " ^ module_name);
          try
            Dynlink.loadfile(module_name)
          with
              Dynlink.Error error -> printh "E" ("Module loading error (" ^ (Dynlink.error_message error) ^ ")");
            | Sys_error error_message -> printh "E" ("Module loading error (" ^ error_message ^ ")");
      with
          Not_found -> printh "E" "Missing argument"
  end;

(*****************************************************************************)
(*               Functions to handle the various user commands               *)
(*****************************************************************************)

(* Each manager gets two (unit -> string), the first one to get tokens
   one after another and the second one to get the tail when required *)

Hashtbl.add cmd_managers
  "TEST"
  begin
    "",
    fun token tail ->
      Hashtbl.iter
        begin
          fun name chan ->
            Hashtbl.iter
              (fun nick user -> print ("on " ^ name ^ " : [" ^ (string_of_user user) ^ "] " ^ nick))
              chan.people
        end
        joined_channels
  end;

Hashtbl.add cmd_managers
  "HELP"
  begin
    "[<cmd>]: Shows the help for the given command, or for all of them",
    fun token tail ->
      try
        let cmd = String.uppercase (token ()) in
          try
            let (h, f) = (Hashtbl.find cmd_managers cmd) in
              printh "H" ("/" ^ cmd ^ " " ^ h)
          with
              Not_found -> printh "H" ("Unknown command " ^ cmd)
      with
          Not_found -> Hashtbl.iter (fun cmd (help, f) -> (printh "H" ("/" ^ cmd ^ " " ^ help))) cmd_managers
  end;

Hashtbl.add cmd_managers
  "ME"
  begin
    "[<action description>]: Describes an action in the default channel",
    fun token tail ->
      if !default_channel = ""
      then printh "E" "Not in a channel"
      else let msg = try (tail ()) with Not_found -> "" in
        tell_server ("PRIVMSG " ^ !default_channel ^ " :
ACTION " ^ msg ^ "
\n");
        print ("* " ^ !current_nick ^ " " ^ msg)
  end;

Hashtbl.add cmd_managers
  "AWAY"
  begin
    "[<message>]: Sets yourself away",
    fun token tail ->
      try tell_server ("AWAY :" ^ (tail ()) ^ "\n")
      with Not_found -> tell_server "AWAY\n";
  end;

Hashtbl.add cmd_managers
  "MSG"
  begin
    "<nick|#channel> <message>: Sends a message to a user, or a channel",
    fun token tail ->
      try
        let dest = (token ()) and msg = (tail ()) in
          tell_ssfe (Tabulable ("/msg " ^ dest ^ " "));
          match String.get dest 0 with
              '#' | '&' ->
                begin
                  print ("<" ^ !current_nick ^ (if same_channel !default_channel dest then "" else "/" ^ dest) ^ "> " ^ msg);
                  tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n")
                end

            |  _ ->
                 begin
                   print (">" ^ dest ^ "< " ^ msg);
                   tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n")
                 end

      with Not_found -> printh "E" "Missing parameter"
  end;

Hashtbl.add cmd_managers
  "CTCP"
  begin
    "<nick|#channel> <ctcp string>: Sends a CTCP (string quoted between ^A) to a user or a channel",
    fun token tail ->
      try
        let dest = (token ()) and msg = (tail ()) in
          tell_ssfe (Tabulable ("/msg " ^ dest ^ " "));
          printh "I" ("Sending a CTCP " ^ msg ^ " to " ^ dest);
          tell_server ("PRIVMSG " ^ dest ^ " :
" ^ msg ^ "
\n")
      with Not_found -> printh "E" "Missing parameter"
  end;

Hashtbl.add cmd_managers
  "NOTICE"
  begin
    "<nick|#channel> <message>: Sends a notice to a user or a channel",
    fun token tail ->
      try
        let dest = (token ()) and msg = (tail ()) in
          print ("-> -" ^ dest ^ "- " ^ msg); tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n")
      with Not_found -> printh "E" "Missing parameter"
  end;

Hashtbl.add cmd_managers
  "WHOIS"
  begin
    "[<nick>]: Requests information about a user",
    fun token tail ->
      let nick = try token () with Not_found -> !current_nick in
        if nick = ""
        then printh "E" "Missing argument"
        else tell_server ("WHOIS " ^ nick ^ "\n")
  end;

Hashtbl.add cmd_managers
  "WI"
  begin
    "[<nick>]: Requests information about a user on his server (get the idle)",
    fun token tail ->
      let nick = try token () with Not_found -> !current_nick in
        if nick = ""
        then printh "E" "Missing argument"
        else tell_server ("WHOIS " ^ nick ^ " " ^ nick ^ "\n")
  end;

Hashtbl.add cmd_managers
  "SERVER"
  begin
    "[<server>[:<port>]]: Establishes a connection to a new server",
    fun token tail ->
      begin
        try
          let (stoken, stail) = tokenizer (token ()) ':' in
            desired_server := stoken ();
            desired_port := int_of_string (stoken ())
        with
            Not_found -> ()
          | Failure(_) -> printh "E" "Syntax error"
      end;
      establish_connection ()
  end;

Hashtbl.add cmd_managers
  "NEXT"
  begin
    ": Selects the next joined channel as default",
    fun token tail ->
      try
        default_channel := (find_joined (circular_succ (String.uppercase !default_channel) (keys joined_channels))).name;
        if not !ssfe then printh "I" ("Talking to " ^ !default_channel ^ " now")
      with
          Not_found -> printh "E" "You have to join a channel first"
  end;

Hashtbl.add cmd_managers
  "JOIN"
  begin
    "[<#channel> [<key>]]: Joins a channel or tells what is the default channel",
    fun token tail ->
      try
        let channel = token () in let chan = match String.get channel 0 with '#' | '&' -> channel | _ -> "#" ^ channel in
        let key = try " " ^ (token ()) with Not_found -> "" in
          if mem_joined channel
          then (default_channel := chan; if not !ssfe then printh "I" ("Talking to " ^ chan ^ " now"))
          else tell_server ("JOIN " ^ chan ^ key ^ "\n")
      with Not_found ->
        if !default_channel = ""
        then printh "I" "You are not in a channel"
        else printh "I" ("You current channel is " ^ !default_channel)
  end;

Hashtbl.add cmd_managers
  "TOPIC"
  begin
    "[<topic>]: Sets or requests the topic in the current channel",
    fun token tail ->
      if !default_channel = ""
      then printh "E" "Not in a channel"
      else
        try let topic = tail () in tell_server ("TOPIC " ^ !default_channel ^ " :" ^ topic ^ "\n")
        with Not_found -> tell_server ("TOPIC " ^ !default_channel ^ "\n")
  end;

Hashtbl.add cmd_managers
  "MODE"
  begin
    "[<mode change>]: Changes mode or shows the mode of the current channel",
    fun token tail ->
      let chan = try token () with Not_found -> !default_channel in
        if chan = ""
        then printh "E" "Need to specify a channel"
        else
          let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in
            try tell_server ("MODE " ^ chan ^ " " ^ (tail ()) ^ "\n")
            with Not_found -> tell_server ("MODE " ^ chan ^ "\n")
  end;

Hashtbl.add cmd_managers
  "KICK"
  begin
    "[<#channel>] <nick> [<comment>]: Kicks the given user from the given (or current) channel",
    fun token tail ->
      if !default_channel = ""
      then printh "E" "Not in a channel"
      else try
        let t = token () in
        let (channel, nick) = match String.get t 0 with '#' | '&' -> (t, token ()) | _ -> (!default_channel, t)
        and comment = try tail () with Not_found -> "B1G d0Rk5 SuCk M00z b4LLz" in
          tell_server ("KICK " ^ !default_channel ^ " " ^ nick ^ " :" ^ comment ^ "\n")
      with Not_found -> printh "E" "Missing parameter"
  end;

Hashtbl.add cmd_managers
  "LEAVE"
  begin
    "[<#channel>]: Leaves the current or the specified channel",
    fun token tail ->
      let chan = try token () with Not_found -> !default_channel in
        if chan = ""
        then printh "E" "Need to specify a channel"
        else let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in
          tell_server ("PART " ^ chan ^ "\n")
  end;

Hashtbl.add cmd_managers
  "CHANINFO"
  begin
    "[<#channel>]: Gets the user list for the given channel",
    fun token tail ->
      let chan = try token () with Not_found -> !default_channel in
        if chan = "" then printh "E" "Need to specify a channel"
        else
          let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in
            tell_server ("LIST " ^ chan ^ "\n");
            tell_server ("NAMES " ^ chan ^ "\n")
  end;

Hashtbl.add cmd_managers
  "NICK"
  begin
    "[<nick>]: Changes or requests the current nick",
    fun token tail ->
      try let nick = token () in tell_server ("NICK " ^ nick ^ "\n")
      with Not_found -> printh "I" ("You current nick is " ^ !current_nick)
  end;

Hashtbl.add cmd_managers
  "DISCONNECT"
  begin
    "[<message>]: Signoffs on the current server with the given quit message",
    fun token tail ->
      let msg = try tail () with Not_found -> (version ^ ", the light IRC client in CAML") in
        tell_server ("QUIT :" ^ msg ^ "\n");
  end;

Hashtbl.add cmd_managers
  "QUIT"
  begin
    "[<message>]: Signoffs on the current server if connected, and terminates operations",
    fun token tail ->
      if !server_connection != Broken then begin
        let msg = try tail () with Not_found -> (version ^ ", the light IRC client in CAML") in
          tell_server ("QUIT :" ^ msg ^ "\n");
      end;
      alive := false
  end;

Hashtbl.add cmd_managers
  "QUOTE"
  begin
    "<line>: Sends the line to the server, as it is",
    fun token tail ->
      try tell_server (tail () ^ "\n")
      with Not_found -> printh "E" "Missing parameter"
  end;

Hashtbl.add cmd_managers
  "VERBOSE"
  begin
    ": Set the verbose mode (everything form the server will be printed)",
    fun token tail ->
      verbose := not !verbose;
      if !verbose then printh "I" "Verbose mode on" else printh "I" "Verbose mode off"
  end;

(*****************************************************************************)
(*                    Function to handle the various CTCPs                   *)
(*****************************************************************************)

Hashtbl.add ctcp_managers
  "VERSION"
  begin
    fun token tail from dest -> tell_server ("NOTICE " ^ from ^ " :" ^ version ^ ", the light IRC client in CAML\n")
  end;;

Hashtbl.add ctcp_managers
  "ACTION"
  begin
    fun token tail from dest -> try print ("* " ^ from ^ " " ^ (tail())) with Not_found -> print ("* " ^ from)
  end;;

(*****************************************************************************)
(*  Functions to handle the mode changes (that part of the protocole sucks)  *)
(*****************************************************************************)

let rec flatten_modes = fun polarity mode_string mode_indice param_strings param_indice ->
  if mode_indice < (String.length mode_string)
  then begin
    match (String.get mode_string mode_indice) with
        '+' -> flatten_modes   1  mode_string (mode_indice+1) param_strings param_indice
      | '-' -> flatten_modes (-1) mode_string (mode_indice+1) param_strings param_indice
      | 'k' | 'o' | 'v' | 'b' as c ->
          (c, polarity, param_strings.(param_indice))::(flatten_modes polarity mode_string (mode_indice+1) param_strings (param_indice+1))
      | 'm' | 'i' | 's' | 't' | 'n' as c ->
          (c, polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice)
      | 'l' ->
          if polarity = 1
          then ('l', polarity, param_strings.(param_indice))::(flatten_modes polarity mode_string (mode_indice+1) param_strings (param_indice+1))
          else ('l', polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice)
      | other -> (other, polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice)
  end
  else []
;;

let rec string_of_modelist = function
    [] -> ""
  | (c,  l,  p)::t ->
      (if l > 0 then " +" else " -") ^
        (String.make 1 c) ^
        (if p = "" then "" else " " ^ p) ^
        (string_of_modelist t)

let set_modes channel l =
  let chan = find_joined channel in
    List.iter
      begin
        function
          | ('b', pol, pattern) -> ()
          | ('v', pol, nick) -> ()
          | ('o', pol, nick) -> (Hashtbl.find chan.people nick).operator <- (pol > 0)
          | (c,  1, param) -> Hashtbl.replace chan.modes c param
          | (c, -1, param) -> Hashtbl.remove chan.modes c
          | _ -> ()
      end
      l;;

let get_status = fun () ->
  " [" ^ version ^ "] " ^
    (try string_of_user (Hashtbl.find (find_joined !default_channel).people !current_nick)
     with Not_found -> "")
  ^ !current_nick ^
    " (+" ^
    (if Hashtbl.mem current_modes 'i' then "i" else "") ^
    (if Hashtbl.mem current_modes 'O' then "i" else "") ^
    (if Hashtbl.mem current_modes 'o' then "i" else "") ^
    (if Hashtbl.mem current_modes 'w' then "w" else "") ^
    (if Hashtbl.mem current_modes 'a' then "a" else "") ^
    ")" ^
    if !default_channel = "" then ""
    else
      " on " ^ !default_channel ^
        let modes = (find_joined !default_channel).modes in
          " (+" ^
            (if Hashtbl.mem modes 'm' then "m" else "") ^
            (if Hashtbl.mem modes 'i' then "i" else "") ^
            (if Hashtbl.mem modes 's' then "s" else "") ^
            (if Hashtbl.mem modes 'n' then "n" else "") ^
            (if Hashtbl.mem modes 't' then "t" else "") ^
            (try " key=" ^ (Hashtbl.find modes 'k') with Not_found -> "") ^
            (try " limit=" ^ (Hashtbl.find modes 'l') with Not_found -> "") ^
            ")"
;;

(*****************************************************************************)
(*     Function to handle the various commands received from the server      *)
(*****************************************************************************)

(* This one just write a certain token as it is *)

let print_information i = fun tokens -> printh "I" tokens.(i);;

(* Here is the serious stuff ... each entry is a fun able to
   interprete the tokens given as parameters *)

Hashtbl.add protocole_managers "001"
  begin
    fun tokens -> current_nick := tokens.(2);
      printh "I" ("You are now connected as " ^ tokens.(2))
  end;

Hashtbl.add protocole_managers "PING"
  begin
    fun tokens -> tell_server ("PONG " ^ tokens.(2) ^ "\n")
  end;

Hashtbl.add protocole_managers "JOIN"
  begin
    fun tokens ->
      let (nick, login, host) = split_prefix tokens.(0) in
        if nick = !current_nick
        then begin
          printh ">" ("You have joined " ^ tokens.(2));
          set_joined tokens.(2) { name=tokens.(2); people= Hashtbl.create 10; modes = Hashtbl.create 10 };
          default_channel := tokens.(2);
          tell_server ("MODE " ^ tokens.(2) ^ "\n")
        end
        else printh ">" (nick ^ " (" ^ login ^ "@" ^ host ^ ") has joined " ^ tokens.(2));
        Hashtbl.replace (find_joined tokens.(2)).people nick { operator = false }
  end;

Hashtbl.add protocole_managers "PART"
  begin
    fun tokens ->
      let (nick, login, host) = split_prefix tokens.(0) in
        if nick = !current_nick
        then begin
          printh "<" ("You have left " ^ tokens.(2));
          part_channel tokens.(2)
        end
        else begin
          printh "<" (nick ^ " (" ^ login ^ "@" ^ host ^ ") has left " ^ tokens.(2));
          Hashtbl.remove (find_joined tokens.(2)).people nick;
        end
  end;

Hashtbl.add protocole_managers "QUIT"
  begin
    fun tokens -> let (nick, login, host) = split_prefix tokens.(0) in
    let channels =
      Hashtbl.fold
        (fun name data s -> if Hashtbl.mem data.people nick then s ^ " " ^ data.name else s)
        joined_channels "" in
      printh "<" ("Signoff: " ^ nick ^ " (" ^ tokens.(2) ^ ") from" ^ channels);
      Hashtbl.iter (fun name data -> Hashtbl.remove data.people nick) joined_channels;
  end;

Hashtbl.add protocole_managers "KICK"
  begin
    fun tokens ->
      let (nick, login, host) = split_prefix tokens.(0) in
        if tokens.(3) = !current_nick
        then begin
          printh "<" ("You have been kicked from " ^ tokens.(2) ^ " by " ^ nick ^ " (" ^ tokens.(4)^ ")");
          part_channel tokens.(2)
        end
        else printh "<" (tokens.(3) ^ " has been kicked from " ^ tokens.(2) ^ " by " ^ nick ^ " (" ^ tokens.(4) ^ ")");
        Hashtbl.remove (find_joined tokens.(2)).people tokens.(3);
  end;

Hashtbl.add protocole_managers "NICK"
  begin
    fun tokens -> let (nick, login, host) = split_prefix tokens.(0) in
      if nick = !current_nick
      then begin
        printh "I" ("You are now known as " ^ tokens.(2));
        current_nick := tokens.(2)
      end
      else printh "I" (nick ^ " is now known as " ^ tokens.(2));
      let rename = begin
        fun name data ->
          let u = Hashtbl.find data.people nick in
            try
              Hashtbl.remove data.people nick;
              Hashtbl.add data.people tokens.(2) u
            with
                Not_found -> ()
      end in
        Hashtbl.iter rename joined_channels;
  end;

Hashtbl.add protocole_managers "MODE"
  begin
    fun tokens ->
      let (nick, login, host) = try split_prefix tokens.(0) with Not_found -> (tokens.(0), "", "") in
      let modes = flatten_modes 1 tokens.(3) 0 tokens 4 in
        if match String.get tokens.(2) 0 with '#' | '&' -> true | _ -> false
        then
          begin
            set_modes (String.uppercase tokens.(2)) modes;
            printh "I" ("Mode change by " ^ nick ^ " on channel " ^ tokens.(2) ^ (string_of_modelist modes))
          end
        else
          begin
            List.iter
              (function (c, 1, x) -> Hashtbl.replace current_modes c x | (c, -1, x) -> Hashtbl.remove current_modes c | _ -> ())
              modes;
            printh "I" ("Mode change" ^ (string_of_modelist modes) ^ " by " ^ nick ^ " for user " ^ tokens.(2))
          end
  end;

Hashtbl.add protocole_managers "TOPIC"
  begin
    fun tokens ->
      let (nick, login, host) = split_prefix tokens.(0) in
        printh "I" (nick ^ " has changed the topic on " ^ tokens.(2) ^ " to \"" ^ tokens.(3) ^ "\"")
  end;

Hashtbl.add protocole_managers "ERROR"
  begin
    fun tokens -> printh "E" tokens.(2)
  end;

Hashtbl.add protocole_managers "PRIVMSG"
  begin
    fun tokens ->
      let (nick, login, host) = split_prefix tokens.(0) in
        try
          let n1 = String.index tokens.(3) '
' in
          let n2 = String.index_from tokens.(3) (n1 + 1) '
' in
          let ctcp_line = (String.sub tokens.(3) (n1 + 1) (n2 - n1 - 1)) in
          let (ctcp_token, ctcp_tail) = tokenizer ctcp_line ' ' in
          let cmd = ctcp_token () in
            try
              (Hashtbl.find ctcp_managers cmd) ctcp_token ctcp_tail nick tokens.(2)
            with
                Not_found -> printh "E" ("Unknown CTCP [" ^ ctcp_line ^ "] from " ^ nick);
                  tell_server ("NOTICE " ^ nick ^ " :Unknown CTCP " ^ cmd ^ "'\n")
        with
            Not_found ->
              begin
                if (String.get tokens.(2) 0) = '#'
                then print ("<" ^ nick ^ (if same_channel tokens.(2) !default_channel then "" else ("/" ^ tokens.(2))) ^ "> " ^
                              tokens.(3))
                else begin
                  tell_ssfe (Tabulable ("/msg " ^ nick ^ " "));
                  print ("[" ^ nick ^ "] " ^ tokens.(3))
                end
              end
  end;

Hashtbl.add protocole_managers "NOTICE"
  begin
    fun tokens ->
      let (nick, login, host) = split_prefix tokens.(0) in
        print ("-" ^ nick ^ (if tokens.(2) = !current_nick then "" else "/" ^ tokens.(2)) ^ "- " ^ tokens.(3))
  end;

Hashtbl.add protocole_managers "301"
  begin
    fun tokens -> printh "I" (tokens.(3) ^ " is away (" ^ tokens.(4) ^ ")")
  end;

Hashtbl.add protocole_managers "311"
  begin
    fun tokens -> printh "I" (tokens.(3) ^ " is " ^ tokens.(4) ^ "@" ^ tokens.(5) ^ " (" ^ tokens.(7) ^ ")")
  end;

Hashtbl.add protocole_managers "312"
  begin
    fun tokens -> printh "I" ("on IRC via server " ^ tokens.(4) ^ " (" ^ tokens.(5) ^ ")")
  end;

Hashtbl.add protocole_managers "317"
  begin
    fun tokens ->
      let duration = int_of_string tokens.(4) in
        printh "I" (tokens.(3) ^ " has been idle for " ^ (duration_of_seconds duration))
  end;

Hashtbl.add protocole_managers "319"
  begin
    fun tokens -> printh "I" ("on channels: " ^ tokens.(4))
  end;

Hashtbl.add protocole_managers "324"
  begin
    fun tokens -> set_modes tokens.(3) (flatten_modes 1 tokens.(4) 0 tokens 5)
  end;

Hashtbl.add protocole_managers "322"
  begin
    fun tokens -> printh "I" ("There are " ^ tokens.(4) ^ " users on " ^ tokens.(3))
  end;

Hashtbl.add protocole_managers "331"
  begin
    fun tokens -> printh "I" ("No topic is set on " ^ tokens.(3))
  end;

Hashtbl.add protocole_managers "333"
  begin
    fun tokens -> printh "I" ("Topic for " ^ tokens.(3) ^ " set by " ^ tokens.(2))
  end;

List.iter
  begin
    fun s -> Hashtbl.add protocole_managers s (print_information 3)
  end
  [ "002"; "003"; "005"; "020"; "042";
    "251"; "252"; "253"; "255"; "265"; "266";
    "372"; "375"; "376";
    "422"; "451" ];

Hashtbl.add protocole_managers "305"
  begin
    fun tokens -> printh "I" tokens.(3); Hashtbl.remove current_modes 'a'
  end;

Hashtbl.add protocole_managers "306"
  begin
    fun tokens -> printh "I" tokens.(3); Hashtbl.replace current_modes 'a' ""
  end;

Hashtbl.add protocole_managers "403" (print_information 4);

List.iter
  begin
    fun s -> Hashtbl.add protocole_managers s (fun tokens -> ())
  end
  [ "318"; "323" ];

Hashtbl.add protocole_managers "004"
  begin
    fun tokens -> printh "I" (tokens.(3) ^ " " ^ tokens.(4) ^ " " ^ tokens.(5) ^ " " ^ tokens.(6))
  end;

Hashtbl.add protocole_managers "254"
  begin
    fun tokens -> printh "I" ("There are " ^ tokens.(3) ^ " " ^ tokens.(4))
  end;

Hashtbl.add protocole_managers "332"
  begin
    fun tokens -> printh "I" ("Topic for " ^ tokens.(3) ^ " is '" ^ tokens.(4) ^ "'")
  end;

Hashtbl.add protocole_managers "353"
  begin
    fun tokens ->
      printh "I" ("Users on " ^ tokens.(4) ^ ": " ^ tokens.(5));
      let (n_token, n_tail) = tokenizer tokens.(5) ' '
      and people_table = (find_joined tokens.(4)).people in
      let rec add_nick = fun () ->
        try
          (let nick = n_token () in match String.get nick 0 with
               '@' -> Hashtbl.replace people_table (String.sub nick 1 ((String.length nick) - 1)) { operator = true }
             |  _ -> Hashtbl.replace people_table nick { operator = false });
          add_nick ()
        with Not_found -> ()
      in add_nick ();
  end;

Hashtbl.add protocole_managers "366"
  begin
    fun tokens -> ()
      (*let users = Hashtbl.fold (fun nick status s -> " " ^ nick ^ s) (find_joined tokens.(3)).people "" in
        printh "I" ("Users on " ^ tokens.(3) ^ ":" ^ users)*)
  end;

Hashtbl.add protocole_managers "401"
  begin
    fun tokens -> printh "E" ("Can not find " ^ tokens.(3) ^ " on IRC")
  end;

Hashtbl.add protocole_managers "433"
  begin
    fun tokens ->
      if tokens.(2) = "*"
      then printh "E" ("Nickname " ^ tokens.(3) ^ " already in used, type /nick <nick> to choose another one")
      else printh "E" ("Nickname " ^ tokens.(3) ^ " already in used, you keep " ^ tokens.(2))
  end;

Hashtbl.add protocole_managers "441"
  begin
    fun tokens -> printh "E" (tokens.(3) ^ " is not on channel " ^ tokens.(4))
  end;

Hashtbl.add protocole_managers "461"
  begin
    fun tokens -> printh "E" ("Not enough parameters for " ^ tokens.(3))
  end;

Hashtbl.add protocole_managers "472"
  begin
    fun tokens -> printh "E" ("Mode '" ^ tokens.(3) ^ "' " ^ tokens.(4))
  end;

Hashtbl.add protocole_managers "474"
  begin
    fun tokens -> printh "E" ("Can not join " ^ tokens.(3) ^ " (banned)")
  end;

Hashtbl.add protocole_managers "475"
  begin
    fun tokens -> printh "E" (tokens.(3) ^ ": " ^ tokens.(4))
  end;

Hashtbl.add protocole_managers "482"
  begin
    fun tokens -> printh "E" ("You are not an operator on " ^ tokens.(3))
  end;

(*****************************************************************************)
(*                         The module initialization                         *)
(*****************************************************************************)

try
  Dynlink.init ();

  Dynlink.add_interfaces
    [ "Ircml"; "Buffer"; "List"; "Arg"; "String"; "Digest"; "Dynlink"; "Hashtbl"; "Sys";
      "Connection"; "Unix"; "Pervasives"; "Array" ]
    [ Sys.getcwd(); "/home/fleuret/local/lib/ocaml" ];

with
    Dynlink.Error error -> printh "E" ("Module loading error (" ^ (Dynlink.error_message error) ^ ")");;

try ignore (Unix.tcgetattr Unix.stdout) with Unix.Unix_error _ -> print "`#ssfe#i";;

(*****************************************************************************)
(*                               The main loop                               *)
(*****************************************************************************)

print "-----------------------------------------------------------------------------";
print (" " ^ version ^ ", the IRC client in OCAML");
print " Written and (c) by <francois.fleuret@epfl.ch>";
print "-----------------------------------------------------------------------------";

establish_connection ();

while !alive do

  flush stdout;

  let (reading, _, _) =  Unix.select (keys fd_active) [] [] 1.0 in

    List.iter
      begin
        fun fd ->
          let h = Hashtbl.find fd_active fd in
            try h.reader () with Network_error(e) -> h.error_handler e
      end
      reading;

    tell_ssfe (Status (get_status ()))

done;

printh "I" "You'll be back, ho yes ... you'll be back"