ircml.ml

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