ircml.ml

   1 (* -*- mode: tuareg -*- ******************************************************)
   2 (*                                                                           *)
   3 (*   This is a light IRC client written in CAML                              *)
   4 (*   Written by and (c) Francois Fleuret, 2002 - 2005                        *)
   5 (*   Contact <francois.fleuret@epfl.ch> for info and bug reports             *)
   6 (*                                                                           *)
   7 (*   This program is free software; you can redistribute it and/or modify    *)
   8 (*   it under the terms of the GNU General Public License Version 2 as       *)
   9 (*   published by the Free Software Foundation. See the file LICENSE for     *)
  10 (*   more details.                                                           *)
  11 (*                                                                           *)
  12 (*****************************************************************************)
  13
  14 open Connection;;
  15
  16 (* I removed all the dcc stuff between v0.25 and v0.5 because it was a
  17    biiiig pile of crap. Feel free to write it ! *)
  18
  19 let version = "IRCML v0.5";;
  20
  21 let term_bold = ref "\e[1m"
  22 and term_underline = ref "\e[4m"
  23 and term_inverse = ref "\e[7m"
  24 and term_reset = ref "\e[m";;
  25
  26 (*****************************************************************************)
  27 (*                                Various stuff                              *)
  28 (*****************************************************************************)
  29
  30 let keys h = Hashtbl.fold (fun key data accu -> key :: accu) h []
  31
  32 let verbose = ref false;;
  33
  34 (* Return the element after the given one, or the first of the list if
  35    the given one is the last *)
  36
  37 let circular_succ =
  38   fun x l ->
  39     let rec next_rec x = function
  40         [] -> raise Not_found
  41       | h::t -> if h = x then List.hd t else next_rec x t
  42     in try next_rec x l with Failure(e) -> List.hd l;;
  43
  44 let string_of_size size =
  45   if size > 1048576 then (string_of_int (size / 1048576))^"Mb"
  46   else if size > 1024 then (string_of_int (size / 1024))^"Kb"
  47   else (string_of_int size) ^ "b";;
  48
  49 let duration_of_seconds duration =
  50   (if duration >= 3600 then (string_of_int (duration/3600))^"h" else "") ^
  51     (if (duration mod 3600) >= 60 then (string_of_int ((duration mod 3600)/60))^"min" else "") ^
  52     (if (duration mod 60) > 0 then (string_of_int (duration mod 60))^"s" else "");;
  53
  54 (*****************************************************************************)
  55 (*                             The global variables                          *)
  56 (*****************************************************************************)
  57
  58 type user_status = { mutable operator: bool }
  59 let string_of_user = fun u -> (if u.operator then "@" else "")
  60
  61 type channel = { name: string; people: (string, user_status) Hashtbl.t ; modes: (char, string) Hashtbl.t };;
  62
  63 let ssfe = ref false
  64
  65 and my_host = ref ""
  66
  67 and desired_nick = ref "b0z0"
  68 and desired_server = ref "localhost"
  69 and desired_port = ref 6667
  70
  71 and current_nick = ref ""
  72 and (current_modes:  (char, string) Hashtbl.t) = Hashtbl.create 10
  73 and default_channel = ref ""
  74
  75 and login = ref "c4mlp0w4"
  76 and name = ref ("Using " ^ version ^ ", the light IRC client in CAML")
  77
  78 and alive = ref true;;
  79
  80 (* Print something with a 'header character' à la sirc                       *)
  81 (* '<' Leaving channel (part, kick, signoff, etc.)                           *)
  82 (* '>' Joining a channel                                                     *)
  83 (* 'E' Error                                                                 *)
  84 (* 'I' Information                                                           *)
  85 (* 'X' Internal error, should never meet one                                 *)
  86 let printh h s = output_string Pervasives.stdout
  87   begin
  88     match h with
  89         "E" -> (!term_bold ^ "*" ^ h ^ "*" ^ " " ^ s ^ !term_reset ^ "\n")
  90       | _   -> (!term_bold ^ "*" ^ h ^ "*" ^ !term_reset ^ " " ^ s ^ "\n")
  91   end;;
  92
  93 (* Simply print something in the console *)
  94 let print s = output_string Pervasives.stdout (s ^ "\n");;
  95
  96 type ssfe_cmd = Status of string | Tabulable of string;;
  97
  98 let current_status = ref "";;
  99
 100 let tell_ssfe x =
 101   if !ssfe then begin
 102     match x with
 103         Status(s) -> if not (s = !current_status) then (current_status := s; print ("`#ssfe#s" ^ s))
 104       | Tabulable(s) -> print ("`#ssfe#t" ^ s)
 105   end;;
 106
 107 (*****************************************************************************)
 108 (*                      Command line parameter parsing                       *)
 109 (*****************************************************************************)
 110
 111 Arg.parse [ ("-nick",   Arg.String(fun n -> desired_nick := n),   "Set the desired nick");
 112             ("-server", Arg.String(fun s -> desired_server := s), "Set the desired server");
 113             ("-port",   Arg.Int(fun p -> desired_port := p),      "Set the desired port");
 114             ("-login",  Arg.String(fun s -> login := s),          "Set the login");
 115             ("-name",   Arg.String(fun s -> name := s),           "Set the name") ]
 116   (fun s -> ()) "Unknown option";;
 117
 118 (*****************************************************************************)
 119 (*                       The connection with the server                      *)
 120 (*****************************************************************************)
 121
 122 type connection =
 123     Established of Unix.file_descr
 124   | Broken;;
 125
 126 let last_server_msg = ref 0;;
 127
 128 let server_connection = ref Broken;;
 129
 130 (* This is the list of file descriptors active for reading. Each one
 131    corresponds to a reader which will be called when something is
 132    readable and a exception-handler, called if the connection is lost,
 133    with the reason *)
 134
 135 type fd_machine = { reader: unit -> unit; error_handler: string -> unit };;
 136
 137 let (fd_active: (Unix.file_descr, fd_machine) Hashtbl.t) = Hashtbl.create 10;;
 138
 139 (*****************************************************************************)
 140 (*                        Handling of the channel list                       *)
 141 (*****************************************************************************)
 142
 143 let (joined_channels: (string, channel) Hashtbl.t) = Hashtbl.create 10;;
 144
 145 let find_joined c = Hashtbl.find joined_channels (String.uppercase c)
 146 and mem_joined c = Hashtbl.mem joined_channels (String.uppercase c)
 147 and set_joined c x = Hashtbl.replace joined_channels (String.uppercase c) x
 148 and remove_joined c = Hashtbl.remove joined_channels (String.uppercase c)
 149 and same_channel c1 c2 = (String.uppercase c1) = (String.uppercase c2);;
 150
 151 let part_channel channel =
 152   remove_joined channel;
 153   if !default_channel = channel
 154   then match (keys joined_channels) with
 155       [] -> default_channel := ""; if not !ssfe then printh "I" "Not in a channel anymore"
 156     | c::t -> default_channel := c; printh "I" ("Talking to " ^ !default_channel ^ " now");;
 157
 158 (*****************************************************************************)
 159 (* Takes a string and returns an array of strings corresponding to the       *)
 160 (* tokens in the IRC protocole syntax. I.e. tokens are separated by white    *)
 161 (* spaces except the tail which is after a ':'                               *)
 162 (*****************************************************************************)
 163
 164 let (irc_tokenize: string -> string array) = fun s ->
 165   let l = (String.length s) in
 166   let rec irc_tokenize s n =
 167     if String.get s n == ':' then [String.sub s (n + 1) (l - n - 2)] else
 168       try
 169         let m = String.index_from s n ' ' in
 170         let h = String.sub s n (m - n) in
 171           h::irc_tokenize s (m+1)
 172       with
 173           Not_found -> if n < l then [String.sub s n (l - n - 1)] else []
 174   in
 175     (* Ignore the prefix if there is one *)
 176     if (String.get s 0) == ':' then
 177       let n = (String.index s ' ') in Array.of_list ((String.sub s 1 (n - 1))::(irc_tokenize s (n+1)))
 178     else Array.of_list (""::(irc_tokenize s 0));;
 179
 180 (* Function to split the "nick!login@host" *)
 181
 182 let (split_prefix: string -> string * string * string) = fun prefix ->
 183   let n1 = (String.index prefix '!') in
 184   let n2 = (String.index_from prefix n1 '@') in
 185     (String.sub prefix 0 n1,
 186      String.sub prefix (n1 + 1) (n2 - (n1 + 1)),
 187      String.sub prefix (n2 + 1) ((String.length prefix) - (n2 + 1)));;
 188
 189 (*****************************************************************************)
 190 (*                             The aliases                                   *)
 191 (*****************************************************************************)
 192
 193 let (cmd_aliases: (string, string) Hashtbl.t) = Hashtbl.create 100;;
 194
 195 List.iter (fun (a, b) -> Hashtbl.replace cmd_aliases a b) [
 196   ("J", "JOIN"); ("M", "MSG"); ("K", "KICK"); ("L", "CHANINFO");
 197   ("N", "NICK"); ("Q", "QUIT"); ("T", "TOPIC"); ("W", "WHOIS");
 198   ("DC", "DISCONNECT"); ("S", "SERVER"); ("H", "HELP")
 199 ];;
 200
 201 (*****************************************************************************)
 202 (*                     The managers will be filled later                     *)
 203 (*****************************************************************************)
 204
 205 let (protocole_managers: (string, string array -> unit) Hashtbl.t) = Hashtbl.create 100;;
 206 let (cmd_managers: (string, string * ((unit -> string) -> (unit -> string) -> unit)) Hashtbl.t) = Hashtbl.create 100;;
 207 let (ctcp_managers: (string, (unit -> string) -> (unit -> string) -> string -> string -> unit) Hashtbl.t) = Hashtbl.create 10;;
 208
 209 (*****************************************************************************)
 210 (*         The routines handling lines from the server or the user           *)
 211 (*****************************************************************************)
 212
 213 let print_unknown_protocole = fun tokens ->
 214   let buffer = Buffer.create 100 in
 215     Buffer.add_string buffer "Unknown protocole";
 216     for i = 0 to ((Array.length tokens) - 1) do
 217       Buffer.add_string buffer (" " ^ (string_of_int i) ^ ":(" ^ tokens.(i) ^ ")");
 218     done;
 219     printh "X" (Buffer.contents buffer);;
 220
 221 let server_line_handler = fun line ->
 222   if !verbose then (print_string ("SERVER [" ^ line ^ "]\n"); flush stdout);
 223   last_server_msg := int_of_float (Unix.time ());
 224   let tokens = (irc_tokenize line) in
 225     try
 226       let f = Hashtbl.find protocole_managers tokens.(1) in
 227         try f tokens with Not_found -> printh "E" ("Protocole " ^ tokens.(1) ^ " raised Not_found!")
 228     with
 229         Not_found -> print_unknown_protocole tokens;;
 230
 231 let kill_server_connection error_message =
 232   match !server_connection with
 233       Established(fd) ->
 234         begin
 235           Hashtbl.remove fd_active fd;
 236           server_connection := Broken;
 237           printh "E" ("Connection lost (" ^ error_message ^ ")");
 238           default_channel := "";
 239           Hashtbl.clear joined_channels
 240         end
 241     | Broken -> exit 1;;
 242
 243 let tell_server line =
 244   match !server_connection with
 245       Established(fd) ->
 246         begin
 247           try
 248             if (Unix.write fd line 0 (String.length line)) <= 0 then kill_server_connection ("write error")
 249           with
 250               Unix.Unix_error(e, fname, fparam) -> kill_server_connection (fname ^ ": " ^ (Unix.error_message e))
 251         end
 252     | Broken -> printh "E" "No connection";;
 253
 254 let establish_connection () =
 255   match !server_connection with
 256       Established(_) -> printh "E" "Connection already established (try /DISCONNECT first)"
 257     | Broken ->
 258         printh "I" ("Attempting connection to " ^ !desired_server ^
 259                       ":" ^ (string_of_int !desired_port) ^
 260                       " with nick " ^ !desired_nick);
 261         try
 262           let fd = Connection.connect !desired_server !desired_port in
 263             begin
 264               match Unix.getsockname fd with
 265                   Unix.ADDR_INET(ai, _) -> my_host := Connection.dot_to_number (Unix.string_of_inet_addr ai)
 266                 | _ -> printh "E" "Internal error #0";
 267             end;
 268             server_connection := Established(fd);
 269             Hashtbl.replace fd_active fd { reader = linizer fd server_line_handler; error_handler = kill_server_connection };
 270             tell_server ("USER " ^ !login ^ " caml rulez :" ^ !name ^ "\n");
 271             tell_server ("NICK " ^ !desired_nick ^ "\n");
 272             last_server_msg := int_of_float (Unix.time ());
 273             printh "I" ("Connection established, waiting for server checkings.");
 274         with
 275             Network_error(e) -> printh "E" ("Can not connect to host: " ^ e);;
 276
 277 let stdin_line_handler = fun line ->
 278   (*print_string ("STDIN  [" ^ line ^ "]\n"); flush stdout;*)
 279   if String.length line > 0 then
 280     match String.get line 0 with
 281         '/' ->
 282           begin
 283             let (cl_token, cl_tail) = tokenizer line ' ' in
 284             let cmd = String.uppercase (cl_token ()) in let cmd = String.sub cmd 1 ((String.length cmd) - 1) in
 285             let cmd = try Hashtbl.find cmd_aliases cmd with Not_found -> cmd in
 286               try
 287                 let (_, f) = (Hashtbl.find cmd_managers cmd) in
 288                   begin
 289                     try
 290                       f cl_token cl_tail
 291                     with
 292                         Not_found -> printh "E" ("Command " ^ cmd ^ " raised Not_found!")
 293                   end
 294               with
 295                   Not_found -> printh "E" ("Unknown command '" ^ cmd ^ "'");
 296           end
 297
 298       | '@' ->
 299           begin
 300             let (cl_token, cl_tail) = tokenizer line ' ' in
 301               match cl_token () with
 302                   "@ssfe@i" ->
 303                     begin
 304                       ssfe := true;
 305                       printh "I" "You are using ssfe";
 306                       term_bold := "\ 2";
 307                       term_underline := "\1f";
 308                       term_inverse := "\16";
 309                       term_reset := "";
 310                     end
 311                 | _ -> ()
 312           end
 313
 314       | _ ->
 315           if !default_channel = ""
 316           then printh "E" "Not in a channel"
 317           else
 318             begin
 319               print ("<" ^ !current_nick ^ "> " ^ line);
 320               tell_server ("PRIVMSG " ^ !default_channel ^ " :" ^ line ^ "\n")
 321             end;;
 322
 323 let console_reader = linizer Unix.stdin stdin_line_handler
 324 and console_error = fun error_message -> printh "E" ("Stdin error (" ^ error_message ^ ")"); exit 1 in
 325   Hashtbl.replace fd_active Unix.stdin { reader = console_reader; error_handler = console_error };;
 326
 327 (*****************************************************************************)
 328 (*                         Functions to handle scripts                       *)
 329 (*****************************************************************************)
 330
 331 Hashtbl.add cmd_managers
 332   "LOAD"
 333   begin
 334     "<module>: Loads the given bytecode object",
 335     fun token tail ->
 336       try
 337         let module_name = token () in
 338           printh "I" ("loading module " ^ module_name);
 339           try
 340             Dynlink.loadfile(module_name)
 341           with
 342               Dynlink.Error error -> printh "E" ("Module loading error (" ^ (Dynlink.error_message error) ^ ")");
 343             | Sys_error error_message -> printh "E" ("Module loading error (" ^ error_message ^ ")");
 344       with
 345           Not_found -> printh "E" "Missing argument"
 346   end;
 347
 348 (*****************************************************************************)
 349 (*               Functions to handle the various user commands               *)
 350 (*****************************************************************************)
 351
 352 (* Each manager gets two (unit -> string), the first one to get tokens
 353    one after another and the second one to get the tail when required *)
 354
 355 Hashtbl.add cmd_managers
 356   "TEST"
 357   begin
 358     "",
 359     fun token tail ->
 360       Hashtbl.iter
 361         begin
 362           fun name chan ->
 363             Hashtbl.iter
 364               (fun nick user -> print ("on " ^ name ^ " : [" ^ (string_of_user user) ^ "] " ^ nick))
 365               chan.people
 366         end
 367         joined_channels
 368   end;
 369
 370 Hashtbl.add cmd_managers
 371   "HELP"
 372   begin
 373     "[<cmd>]: Shows the help for the given command, or for all of them",
 374     fun token tail ->
 375       try
 376         let cmd = String.uppercase (token ()) in
 377           try
 378             let (h, f) = (Hashtbl.find cmd_managers cmd) in
 379               printh "H" ("/" ^ cmd ^ " " ^ h)
 380           with
 381               Not_found -> printh "H" ("Unknown command " ^ cmd)
 382       with
 383           Not_found -> Hashtbl.iter (fun cmd (help, f) -> (printh "H" ("/" ^ cmd ^ " " ^ help))) cmd_managers
 384   end;
 385
 386 Hashtbl.add cmd_managers
 387   "ME"
 388   begin
 389     "[<action description>]: Describes an action in the default channel",
 390     fun token tail ->
 391       if !default_channel = ""
 392       then printh "E" "Not in a channel"
 393       else let msg = try (tail ()) with Not_found -> "" in
 394         tell_server ("PRIVMSG " ^ !default_channel ^ " :\ 1ACTION " ^ msg ^ "\ 1\n");
 395         print ("* " ^ !current_nick ^ " " ^ msg)
 396   end;
 397
 398 Hashtbl.add cmd_managers
 399   "AWAY"
 400   begin
 401     "[<message>]: Sets yourself away",
 402     fun token tail ->
 403       try tell_server ("AWAY :" ^ (tail ()) ^ "\n")
 404       with Not_found -> tell_server "AWAY\n";
 405   end;
 406
 407 Hashtbl.add cmd_managers
 408   "MSG"
 409   begin
 410     "<nick|#channel> <message>: Sends a message to a user, or a channel",
 411     fun token tail ->
 412       try
 413         let dest = (token ()) and msg = (tail ()) in
 414           tell_ssfe (Tabulable ("/msg " ^ dest ^ " "));
 415           match String.get dest 0 with
 416               '#' | '&' ->
 417                 begin
 418                   print ("<" ^ !current_nick ^ (if same_channel !default_channel dest then "" else "/" ^ dest) ^ "> " ^ msg);
 419                   tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n")
 420                 end
 421
 422             |  _ ->
 423                  begin
 424                    print (">" ^ dest ^ "< " ^ msg);
 425                    tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n")
 426                  end
 427
 428       with Not_found -> printh "E" "Missing parameter"
 429   end;
 430
 431 Hashtbl.add cmd_managers
 432   "CTCP"
 433   begin
 434     "<nick|#channel> <ctcp string>: Sends a CTCP (string quoted between ^A) to a user or a channel",
 435     fun token tail ->
 436       try
 437         let dest = (token ()) and msg = (tail ()) in
 438           tell_ssfe (Tabulable ("/msg " ^ dest ^ " "));
 439           printh "I" ("Sending a CTCP " ^ msg ^ " to " ^ dest);
 440           tell_server ("PRIVMSG " ^ dest ^ " :\ 1" ^ msg ^ "\ 1\n")
 441       with Not_found -> printh "E" "Missing parameter"
 442   end;
 443
 444 Hashtbl.add cmd_managers
 445   "NOTICE"
 446   begin
 447     "<nick|#channel> <message>: Sends a notice to a user or a channel",
 448     fun token tail ->
 449       try
 450         let dest = (token ()) and msg = (tail ()) in
 451           print ("-> -" ^ dest ^ "- " ^ msg); tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n")
 452       with Not_found -> printh "E" "Missing parameter"
 453   end;
 454
 455 Hashtbl.add cmd_managers
 456   "WHOIS"
 457   begin
 458     "[<nick>]: Requests information about a user",
 459     fun token tail ->
 460       let nick = try token () with Not_found -> !current_nick in
 461         if nick = ""
 462         then printh "E" "Missing argument"
 463         else tell_server ("WHOIS " ^ nick ^ "\n")
 464   end;
 465
 466 Hashtbl.add cmd_managers
 467   "WI"
 468   begin
 469     "[<nick>]: Requests information about a user on his server (get the idle)",
 470     fun token tail ->
 471       let nick = try token () with Not_found -> !current_nick in
 472         if nick = ""
 473         then printh "E" "Missing argument"
 474         else tell_server ("WHOIS " ^ nick ^ " " ^ nick ^ "\n")
 475   end;
 476
 477 Hashtbl.add cmd_managers
 478   "SERVER"
 479   begin
 480     "[<server>[:<port>]]: Establishes a connection to a new server",
 481     fun token tail ->
 482       begin
 483         try
 484           let (stoken, stail) = tokenizer (token ()) ':' in
 485             desired_server := stoken ();
 486             desired_port := int_of_string (stoken ())
 487         with
 488             Not_found -> ()
 489           | Failure(_) -> printh "E" "Syntax error"
 490       end;
 491       establish_connection ()
 492   end;
 493
 494 Hashtbl.add cmd_managers
 495   "NEXT"
 496   begin
 497     ": Selects the next joined channel as default",
 498     fun token tail ->
 499       try
 500         default_channel := (find_joined (circular_succ (String.uppercase !default_channel) (keys joined_channels))).name;
 501         if not !ssfe then printh "I" ("Talking to " ^ !default_channel ^ " now")
 502       with
 503           Not_found -> printh "E" "You have to join a channel first"
 504   end;
 505
 506 Hashtbl.add cmd_managers
 507   "JOIN"
 508   begin
 509     "[<#channel> [<key>]]: Joins a channel or tells what is the default channel",
 510     fun token tail ->
 511       try
 512         let channel = token () in let chan = match String.get channel 0 with '#' | '&' -> channel | _ -> "#" ^ channel in
 513         let key = try " " ^ (token ()) with Not_found -> "" in
 514           if mem_joined channel
 515           then (default_channel := chan; if not !ssfe then printh "I" ("Talking to " ^ chan ^ " now"))
 516           else tell_server ("JOIN " ^ chan ^ key ^ "\n")
 517       with Not_found ->
 518         if !default_channel = ""
 519         then printh "I" "You are not in a channel"
 520         else printh "I" ("You current channel is " ^ !default_channel)
 521   end;
 522
 523 Hashtbl.add cmd_managers
 524   "TOPIC"
 525   begin
 526     "[<topic>]: Sets or requests the topic in the current channel",
 527     fun token tail ->
 528       if !default_channel = ""
 529       then printh "E" "Not in a channel"
 530       else
 531         try let topic = tail () in tell_server ("TOPIC " ^ !default_channel ^ " :" ^ topic ^ "\n")
 532         with Not_found -> tell_server ("TOPIC " ^ !default_channel ^ "\n")
 533   end;
 534
 535 Hashtbl.add cmd_managers
 536   "MODE"
 537   begin
 538     "[<mode change>]: Changes mode or shows the mode of the current channel",
 539     fun token tail ->
 540       let chan = try token () with Not_found -> !default_channel in
 541         if chan = ""
 542         then printh "E" "Need to specify a channel"
 543         else
 544           let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in
 545             try tell_server ("MODE " ^ chan ^ " " ^ (tail ()) ^ "\n")
 546             with Not_found -> tell_server ("MODE " ^ chan ^ "\n")
 547   end;
 548
 549 Hashtbl.add cmd_managers
 550   "KICK"
 551   begin
 552     "[<#channel>] <nick> [<comment>]: Kicks the given user from the given (or current) channel",
 553     fun token tail ->
 554       if !default_channel = ""
 555       then printh "E" "Not in a channel"
 556       else try
 557         let t = token () in
 558         let (channel, nick) = match String.get t 0 with '#' | '&' -> (t, token ()) | _ -> (!default_channel, t)
 559         and comment = try tail () with Not_found -> "B1G d0Rk5 SuCk M00z b4LLz" in
 560           tell_server ("KICK " ^ !default_channel ^ " " ^ nick ^ " :" ^ comment ^ "\n")
 561       with Not_found -> printh "E" "Missing parameter"
 562   end;
 563
 564 Hashtbl.add cmd_managers
 565   "LEAVE"
 566   begin
 567     "[<#channel>]: Leaves the current or the specified channel",
 568     fun token tail ->
 569       let chan = try token () with Not_found -> !default_channel in
 570         if chan = ""
 571         then printh "E" "Need to specify a channel"
 572         else let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in
 573           tell_server ("PART " ^ chan ^ "\n")
 574   end;
 575
 576 Hashtbl.add cmd_managers
 577   "CHANINFO"
 578   begin
 579     "[<#channel>]: Gets the user list for the given channel",
 580     fun token tail ->
 581       let chan = try token () with Not_found -> !default_channel in
 582         if chan = "" then printh "E" "Need to specify a channel"
 583         else
 584           let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in
 585             tell_server ("LIST " ^ chan ^ "\n");
 586             tell_server ("NAMES " ^ chan ^ "\n")
 587   end;
 588
 589 Hashtbl.add cmd_managers
 590   "NICK"
 591   begin
 592     "[<nick>]: Changes or requests the current nick",
 593     fun token tail ->
 594       try let nick = token () in tell_server ("NICK " ^ nick ^ "\n")
 595       with Not_found -> printh "I" ("You current nick is " ^ !current_nick)
 596   end;
 597
 598 Hashtbl.add cmd_managers
 599   "DISCONNECT"
 600   begin
 601     "[<message>]: Signoffs on the current server with the given quit message",
 602     fun token tail ->
 603       let msg = try tail () with Not_found -> (version ^ ", the light IRC client in CAML") in
 604         tell_server ("QUIT :" ^ msg ^ "\n");
 605   end;
 606
 607 Hashtbl.add cmd_managers
 608   "QUIT"
 609   begin
 610     "[<message>]: Signoffs on the current server if connected, and terminates operations",
 611     fun token tail ->
 612       if !server_connection != Broken then begin
 613         let msg = try tail () with Not_found -> (version ^ ", the light IRC client in CAML") in
 614           tell_server ("QUIT :" ^ msg ^ "\n");
 615       end;
 616       alive := false
 617   end;
 618
 619 Hashtbl.add cmd_managers
 620   "QUOTE"
 621   begin
 622     "<line>: Sends the line to the server, as it is",
 623     fun token tail ->
 624       try tell_server (tail () ^ "\n")
 625       with Not_found -> printh "E" "Missing parameter"
 626   end;
 627
 628 Hashtbl.add cmd_managers
 629   "VERBOSE"
 630   begin
 631     ": Set the verbose mode (everything form the server will be printed)",
 632     fun token tail ->
 633       verbose := not !verbose;
 634       if !verbose then printh "I" "Verbose mode on" else printh "I" "Verbose mode off"
 635   end;
 636
 637 (*****************************************************************************)
 638 (*                    Function to handle the various CTCPs                   *)
 639 (*****************************************************************************)
 640
 641 Hashtbl.add ctcp_managers
 642   "VERSION"
 643   begin
 644     fun token tail from dest -> tell_server ("NOTICE " ^ from ^ " :" ^ version ^ ", the light IRC client in CAML\n")
 645   end;;
 646
 647 Hashtbl.add ctcp_managers
 648   "ACTION"
 649   begin
 650     fun token tail from dest -> try print ("* " ^ from ^ " " ^ (tail())) with Not_found -> print ("* " ^ from)
 651   end;;
 652
 653 (*****************************************************************************)
 654 (*  Functions to handle the mode changes (that part of the protocole sucks)  *)
 655 (*****************************************************************************)
 656
 657 let rec flatten_modes = fun polarity mode_string mode_indice param_strings param_indice ->
 658   if mode_indice < (String.length mode_string)
 659   then begin
 660     match (String.get mode_string mode_indice) with
 661         '+' -> flatten_modes   1  mode_string (mode_indice+1) param_strings param_indice
 662       | '-' -> flatten_modes (-1) mode_string (mode_indice+1) param_strings param_indice
 663       | 'k' | 'o' | 'v' | 'b' as c ->
 664           (c, polarity, param_strings.(param_indice))::(flatten_modes polarity mode_string (mode_indice+1) param_strings (param_indice+1))
 665       | 'm' | 'i' | 's' | 't' | 'n' as c ->
 666           (c, polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice)
 667       | 'l' ->
 668           if polarity = 1
 669           then ('l', polarity, param_strings.(param_indice))::(flatten_modes polarity mode_string (mode_indice+1) param_strings (param_indice+1))
 670           else ('l', polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice)
 671       | other -> (other, polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice)
 672   end
 673   else []
 674 ;;
 675
 676 let rec string_of_modelist = function
 677     [] -> ""
 678   | (c,  l,  p)::t ->
 679       (if l > 0 then " +" else " -") ^
 680         (String.make 1 c) ^
 681         (if p = "" then "" else " " ^ p) ^
 682         (string_of_modelist t)
 683
 684 let set_modes channel l =
 685   let chan = find_joined channel in
 686     List.iter
 687       begin
 688         function
 689           | ('b', pol, pattern) -> ()
 690           | ('v', pol, nick) -> ()
 691           | ('o', pol, nick) -> (Hashtbl.find chan.people nick).operator <- (pol > 0)
 692           | (c,  1, param) -> Hashtbl.replace chan.modes c param
 693           | (c, -1, param) -> Hashtbl.remove chan.modes c
 694           | _ -> ()
 695       end
 696       l;;
 697
 698 let get_status = fun () ->
 699   " [" ^ version ^ "] " ^
 700     (try string_of_user (Hashtbl.find (find_joined !default_channel).people !current_nick)
 701      with Not_found -> "")
 702   ^ !current_nick ^
 703     " (+" ^
 704     (if Hashtbl.mem current_modes 'i' then "i" else "") ^
 705     (if Hashtbl.mem current_modes 'O' then "i" else "") ^
 706     (if Hashtbl.mem current_modes 'o' then "i" else "") ^
 707     (if Hashtbl.mem current_modes 'w' then "w" else "") ^
 708     (if Hashtbl.mem current_modes 'a' then "a" else "") ^
 709     ")" ^
 710     if !default_channel = "" then ""
 711     else
 712       " on " ^ !default_channel ^
 713         let modes = (find_joined !default_channel).modes in
 714           " (+" ^
 715             (if Hashtbl.mem modes 'm' then "m" else "") ^
 716             (if Hashtbl.mem modes 'i' then "i" else "") ^
 717             (if Hashtbl.mem modes 's' then "s" else "") ^
 718             (if Hashtbl.mem modes 'n' then "n" else "") ^
 719             (if Hashtbl.mem modes 't' then "t" else "") ^
 720             (try " key=" ^ (Hashtbl.find modes 'k') with Not_found -> "") ^
 721             (try " limit=" ^ (Hashtbl.find modes 'l') with Not_found -> "") ^
 722             ")"
 723 ;;
 724
 725 (*****************************************************************************)
 726 (*     Function to handle the various commands received from the server      *)
 727 (*****************************************************************************)
 728
 729 (* This one just write a certain token as it is *)
 730
 731 let print_information i = fun tokens -> printh "I" tokens.(i);;
 732
 733 (* Here is the serious stuff ... each entry is a fun able to
 734    interprete the tokens given as parameters *)
 735
 736 Hashtbl.add protocole_managers "001"
 737   begin
 738     fun tokens -> current_nick := tokens.(2);
 739       printh "I" ("You are now connected as " ^ tokens.(2))
 740   end;
 741
 742 Hashtbl.add protocole_managers "PING"
 743   begin
 744     fun tokens -> tell_server ("PONG " ^ tokens.(2) ^ "\n")
 745   end;
 746
 747 Hashtbl.add protocole_managers "JOIN"
 748   begin
 749     fun tokens ->
 750       let (nick, login, host) = split_prefix tokens.(0) in
 751         if nick = !current_nick
 752         then begin
 753           printh ">" ("You have joined " ^ tokens.(2));
 754           set_joined tokens.(2) { name=tokens.(2); people= Hashtbl.create 10; modes = Hashtbl.create 10 };
 755           default_channel := tokens.(2);
 756           tell_server ("MODE " ^ tokens.(2) ^ "\n")
 757         end
 758         else printh ">" (nick ^ " (" ^ login ^ "@" ^ host ^ ") has joined " ^ tokens.(2));
 759         Hashtbl.replace (find_joined tokens.(2)).people nick { operator = false }
 760   end;
 761
 762 Hashtbl.add protocole_managers "PART"
 763   begin
 764     fun tokens ->
 765       let (nick, login, host) = split_prefix tokens.(0) in
 766         if nick = !current_nick
 767         then begin
 768           printh "<" ("You have left " ^ tokens.(2));
 769           part_channel tokens.(2)
 770         end
 771         else begin
 772           printh "<" (nick ^ " (" ^ login ^ "@" ^ host ^ ") has left " ^ tokens.(2));
 773           Hashtbl.remove (find_joined tokens.(2)).people nick;
 774         end
 775   end;
 776
 777 Hashtbl.add protocole_managers "QUIT"
 778   begin
 779     fun tokens -> let (nick, login, host) = split_prefix tokens.(0) in
 780     let channels =
 781       Hashtbl.fold
 782         (fun name data s -> if Hashtbl.mem data.people nick then s ^ " " ^ data.name else s)
 783         joined_channels "" in
 784       printh "<" ("Signoff: " ^ nick ^ " (" ^ tokens.(2) ^ ") from" ^ channels);
 785       Hashtbl.iter (fun name data -> Hashtbl.remove data.people nick) joined_channels;
 786   end;
 787
 788 Hashtbl.add protocole_managers "KICK"
 789   begin
 790     fun tokens ->
 791       let (nick, login, host) = split_prefix tokens.(0) in
 792         if tokens.(3) = !current_nick
 793         then begin
 794           printh "<" ("You have been kicked from " ^ tokens.(2) ^ " by " ^ nick ^ " (" ^ tokens.(4)^ ")");
 795           part_channel tokens.(2)
 796         end
 797         else printh "<" (tokens.(3) ^ " has been kicked from " ^ tokens.(2) ^ " by " ^ nick ^ " (" ^ tokens.(4) ^ ")");
 798         Hashtbl.remove (find_joined tokens.(2)).people tokens.(3);
 799   end;
 800
 801 Hashtbl.add protocole_managers "NICK"
 802   begin
 803     fun tokens -> let (nick, login, host) = split_prefix tokens.(0) in
 804       if nick = !current_nick
 805       then begin
 806         printh "I" ("You are now known as " ^ tokens.(2));
 807         current_nick := tokens.(2)
 808       end
 809       else printh "I" (nick ^ " is now known as " ^ tokens.(2));
 810       let rename = begin
 811         fun name data ->
 812           let u = Hashtbl.find data.people nick in
 813             try
 814               Hashtbl.remove data.people nick;
 815               Hashtbl.add data.people tokens.(2) u
 816             with
 817                 Not_found -> ()
 818       end in
 819         Hashtbl.iter rename joined_channels;
 820   end;
 821
 822 Hashtbl.add protocole_managers "MODE"
 823   begin
 824     fun tokens ->
 825       let (nick, login, host) = try split_prefix tokens.(0) with Not_found -> (tokens.(0), "", "") in
 826       let modes = flatten_modes 1 tokens.(3) 0 tokens 4 in
 827         if match String.get tokens.(2) 0 with '#' | '&' -> true | _ -> false
 828         then
 829           begin
 830             set_modes (String.uppercase tokens.(2)) modes;
 831             printh "I" ("Mode change by " ^ nick ^ " on channel " ^ tokens.(2) ^ (string_of_modelist modes))
 832           end
 833         else
 834           begin
 835             List.iter
 836               (function (c, 1, x) -> Hashtbl.replace current_modes c x | (c, -1, x) -> Hashtbl.remove current_modes c | _ -> ())
 837               modes;
 838             printh "I" ("Mode change" ^ (string_of_modelist modes) ^ " by " ^ nick ^ " for user " ^ tokens.(2))
 839           end
 840   end;
 841
 842 Hashtbl.add protocole_managers "TOPIC"
 843   begin
 844     fun tokens ->
 845       let (nick, login, host) = split_prefix tokens.(0) in
 846         printh "I" (nick ^ " has changed the topic on " ^ tokens.(2) ^ " to \"" ^ tokens.(3) ^ "\"")
 847   end;
 848
 849 Hashtbl.add protocole_managers "ERROR"
 850   begin
 851     fun tokens -> printh "E" tokens.(2)
 852   end;
 853
 854 Hashtbl.add protocole_managers "PRIVMSG"
 855   begin
 856     fun tokens ->
 857       let (nick, login, host) = split_prefix tokens.(0) in
 858         try
 859           let n1 = String.index tokens.(3) '\ 1' in
 860           let n2 = String.index_from tokens.(3) (n1 + 1) '\ 1' in
 861           let ctcp_line = (String.sub tokens.(3) (n1 + 1) (n2 - n1 - 1)) in
 862           let (ctcp_token, ctcp_tail) = tokenizer ctcp_line ' ' in
 863           let cmd = ctcp_token () in
 864             try
 865               (Hashtbl.find ctcp_managers cmd) ctcp_token ctcp_tail nick tokens.(2)
 866             with
 867                 Not_found -> printh "E" ("Unknown CTCP [" ^ ctcp_line ^ "] from " ^ nick);
 868                   tell_server ("NOTICE " ^ nick ^ " :Unknown CTCP " ^ cmd ^ "'\n")
 869         with
 870             Not_found ->
 871               begin
 872                 if (String.get tokens.(2) 0) = '#'
 873                 then print ("<" ^ nick ^ (if same_channel tokens.(2) !default_channel then "" else ("/" ^ tokens.(2))) ^ "> " ^
 874                               tokens.(3))
 875                 else begin
 876                   tell_ssfe (Tabulable ("/msg " ^ nick ^ " "));
 877                   print ("[" ^ nick ^ "] " ^ tokens.(3))
 878                 end
 879               end
 880   end;
 881
 882 Hashtbl.add protocole_managers "NOTICE"
 883   begin
 884     fun tokens ->
 885       let (nick, login, host) = split_prefix tokens.(0) in
 886         print ("-" ^ nick ^ (if tokens.(2) = !current_nick then "" else "/" ^ tokens.(2)) ^ "- " ^ tokens.(3))
 887   end;
 888
 889 Hashtbl.add protocole_managers "301"
 890   begin
 891     fun tokens -> printh "I" (tokens.(3) ^ " is away (" ^ tokens.(4) ^ ")")
 892   end;
 893
 894 Hashtbl.add protocole_managers "311"
 895   begin
 896     fun tokens -> printh "I" (tokens.(3) ^ " is " ^ tokens.(4) ^ "@" ^ tokens.(5) ^ " (" ^ tokens.(7) ^ ")")
 897   end;
 898
 899 Hashtbl.add protocole_managers "312"
 900   begin
 901     fun tokens -> printh "I" ("on IRC via server " ^ tokens.(4) ^ " (" ^ tokens.(5) ^ ")")
 902   end;
 903
 904 Hashtbl.add protocole_managers "317"
 905   begin
 906     fun tokens ->
 907       let duration = int_of_string tokens.(4) in
 908         printh "I" (tokens.(3) ^ " has been idle for " ^ (duration_of_seconds duration))
 909   end;
 910
 911 Hashtbl.add protocole_managers "319"
 912   begin
 913     fun tokens -> printh "I" ("on channels: " ^ tokens.(4))
 914   end;
 915
 916 Hashtbl.add protocole_managers "324"
 917   begin
 918     fun tokens -> set_modes tokens.(3) (flatten_modes 1 tokens.(4) 0 tokens 5)
 919   end;
 920
 921 Hashtbl.add protocole_managers "322"
 922   begin
 923     fun tokens -> printh "I" ("There are " ^ tokens.(4) ^ " users on " ^ tokens.(3))
 924   end;
 925
 926 Hashtbl.add protocole_managers "331"
 927   begin
 928     fun tokens -> printh "I" ("No topic is set on " ^ tokens.(3))
 929   end;
 930
 931 Hashtbl.add protocole_managers "333"
 932   begin
 933     fun tokens -> printh "I" ("Topic for " ^ tokens.(3) ^ " set by " ^ tokens.(2))
 934   end;
 935
 936 List.iter
 937   begin
 938     fun s -> Hashtbl.add protocole_managers s (print_information 3)
 939   end
 940   [ "002"; "003"; "005"; "020"; "042";
 941     "251"; "252"; "253"; "255"; "265"; "266";
 942     "372"; "375"; "376";
 943     "422"; "451" ];
 944
 945 Hashtbl.add protocole_managers "305"
 946   begin
 947     fun tokens -> printh "I" tokens.(3); Hashtbl.remove current_modes 'a'
 948   end;
 949
 950 Hashtbl.add protocole_managers "306"
 951   begin
 952     fun tokens -> printh "I" tokens.(3); Hashtbl.replace current_modes 'a' ""
 953   end;
 954
 955 Hashtbl.add protocole_managers "403" (print_information 4);
 956
 957 List.iter
 958   begin
 959     fun s -> Hashtbl.add protocole_managers s (fun tokens -> ())
 960   end
 961   [ "318"; "323" ];
 962
 963 Hashtbl.add protocole_managers "004"
 964   begin
 965     fun tokens -> printh "I" (tokens.(3) ^ " " ^ tokens.(4) ^ " " ^ tokens.(5) ^ " " ^ tokens.(6))
 966   end;
 967
 968 Hashtbl.add protocole_managers "254"
 969   begin
 970     fun tokens -> printh "I" ("There are " ^ tokens.(3) ^ " " ^ tokens.(4))
 971   end;
 972
 973 Hashtbl.add protocole_managers "332"
 974   begin
 975     fun tokens -> printh "I" ("Topic for " ^ tokens.(3) ^ " is '" ^ tokens.(4) ^ "'")
 976   end;
 977
 978 Hashtbl.add protocole_managers "353"
 979   begin
 980     fun tokens ->
 981       printh "I" ("Users on " ^ tokens.(4) ^ ": " ^ tokens.(5));
 982       let (n_token, n_tail) = tokenizer tokens.(5) ' '
 983       and people_table = (find_joined tokens.(4)).people in
 984       let rec add_nick = fun () ->
 985         try
 986           (let nick = n_token () in match String.get nick 0 with
 987                '@' -> Hashtbl.replace people_table (String.sub nick 1 ((String.length nick) - 1)) { operator = true }
 988              |  _ -> Hashtbl.replace people_table nick { operator = false });
 989           add_nick ()
 990         with Not_found -> ()
 991       in add_nick ();
 992   end;
 993
 994 Hashtbl.add protocole_managers "366"
 995   begin
 996     fun tokens -> ()
 997       (*let users = Hashtbl.fold (fun nick status s -> " " ^ nick ^ s) (find_joined tokens.(3)).people "" in
 998         printh "I" ("Users on " ^ tokens.(3) ^ ":" ^ users)*)
 999   end;
1000
1001 Hashtbl.add protocole_managers "401"
1002   begin
1003     fun tokens -> printh "E" ("Can not find " ^ tokens.(3) ^ " on IRC")
1004   end;
1005
1006 Hashtbl.add protocole_managers "433"
1007   begin
1008     fun tokens ->
1009       if tokens.(2) = "*"
1010       then printh "E" ("Nickname " ^ tokens.(3) ^ " already in used, type /nick <nick> to choose another one")
1011       else printh "E" ("Nickname " ^ tokens.(3) ^ " already in used, you keep " ^ tokens.(2))
1012   end;
1013
1014 Hashtbl.add protocole_managers "441"
1015   begin
1016     fun tokens -> printh "E" (tokens.(3) ^ " is not on channel " ^ tokens.(4))
1017   end;
1018
1019 Hashtbl.add protocole_managers "461"
1020   begin
1021     fun tokens -> printh "E" ("Not enough parameters for " ^ tokens.(3))
1022   end;
1023
1024 Hashtbl.add protocole_managers "472"
1025   begin
1026     fun tokens -> printh "E" ("Mode '" ^ tokens.(3) ^ "' " ^ tokens.(4))
1027   end;
1028
1029 Hashtbl.add protocole_managers "474"
1030   begin
1031     fun tokens -> printh "E" ("Can not join " ^ tokens.(3) ^ " (banned)")
1032   end;
1033
1034 Hashtbl.add protocole_managers "475"
1035   begin
1036     fun tokens -> printh "E" (tokens.(3) ^ ": " ^ tokens.(4))
1037   end;
1038
1039 Hashtbl.add protocole_managers "482"
1040   begin
1041     fun tokens -> printh "E" ("You are not an operator on " ^ tokens.(3))
1042   end;
1043
1044 (*****************************************************************************)
1045 (*                         The module initialization                         *)
1046 (*****************************************************************************)
1047
1048 try
1049   Dynlink.init ();
1050
1051   Dynlink.add_interfaces
1052     [ "Ircml"; "Buffer"; "List"; "Arg"; "String"; "Digest"; "Dynlink"; "Hashtbl"; "Sys";
1053       "Connection"; "Unix"; "Pervasives"; "Array" ]
1054     [ Sys.getcwd(); "/home/fleuret/local/lib/ocaml" ];
1055
1056 with
1057     Dynlink.Error error -> printh "E" ("Module loading error (" ^ (Dynlink.error_message error) ^ ")");;
1058
1059 try ignore (Unix.tcgetattr Unix.stdout) with Unix.Unix_error _ -> print "`#ssfe#i";;
1060
1061 (*****************************************************************************)
1062 (*                               The main loop                               *)
1063 (*****************************************************************************)
1064
1065 print "-----------------------------------------------------------------------------";
1066 print (" " ^ version ^ ", the IRC client in OCAML");
1067 print " Written and (c) by <francois.fleuret@epfl.ch>";
1068 print "-----------------------------------------------------------------------------";
1069
1070 establish_connection ();
1071
1072 while !alive do
1073
1074   flush stdout;
1075
1076   let (reading, _, _) =  Unix.select (keys fd_active) [] [] 1.0 in
1077
1078     List.iter
1079       begin
1080         fun fd ->
1081           let h = Hashtbl.find fd_active fd in
1082             try h.reader () with Network_error(e) -> h.error_handler e
1083       end
1084       reading;
1085
1086     tell_ssfe (Status (get_status ()))
1087
1088 done;
1089
1090 printh "I" "You'll be back, ho yes ... you'll be back"