irc-bot/client.ml

open Irc

(* ==========================================
 * Client stuff
 *)
type t = {iobuf: Iobuf.t;
          nick: string ref;
          away: string option ref;
          username: string;
          realname: string}

exception Error of Command.t

let modes = "l"

let dbg msg a = prerr_endline msg; a

let by_nick = Hashtbl.create 25

let lookup nick =
  Hashtbl.find by_nick nick

let error num args text =
  Error (Command.create (Some !(Irc.name)) num args (Some text))

let nuhost cli = (!(cli.nick), cli.username, (Iobuf.addr cli.iobuf))

let kill cli message = 
  Iobuf.close cli.iobuf ("Killed: " ^ message)

let write_command cli cmd =
  Iobuf.write cli.iobuf cmd

let write cli sender name args text =
  write_command cli (Command.create sender name args text)

let reply cli num ?(args=[]) text =
  write cli (Some !(Irc.name)) num (!(cli.nick) :: args) (Some text)

let handle_error cli iobuf message =
  Hashtbl.remove by_nick !(cli.nick)

let handle_command cli iobuf cmd =
  match (Command.as_tuple cmd) with
    | (None, "OPER", [name; password], None) ->
        ()
    | (None, "MODE", target :: args, None) ->
        ()
    | (None, "SERVICE", [nickname; _; distribution; svctype; _], Some info) ->
        ()
    | (None, "QUIT", [], None) ->
        write cli (Some !(Irc.name)) "ERROR" [] (Some "So long");
        Iobuf.close iobuf "No reason provided"
    | (None, "QUIT", [], Some message) ->
        write cli (Some !(Irc.name)) "ERROR" [] (Some "So long");
        Iobuf.close iobuf message
    | (None, "JOIN", ["0"], None) ->
        ()
    | (None, "JOIN", [channels], None) ->
        Channel.handle_command cli.iobuf (nuhost cli) cmd
    | (None, "JOIN", [channels; keys], None) ->
        ()
    | (None, "PART", [channels], message) ->
        ()
    | (None, "TOPIC", [channel], None) ->
        ()
    | (None, "TOPIC", [channel], Some topic) ->
        ()
    | (None, "NAMES", [channels], None) ->
        ()
    | (None, "LIST", [channels], None) ->
        ()
    | (None, "INVITE", [nickname; channel], None) ->
        ()
    | (None, "KICK", [channels; users], comment) ->
        ()
    | (None, ("PRIVMSG" as command), [target], Some text)
    | (None, ("NOTICE" as command), [target], Some text) ->
        if Channel.is_channel_name target then
          Channel.handle_command cli.iobuf (nuhost cli) cmd
        else
          begin
            try
              let peer = lookup target in
                write peer 
                  (Some (Irc.string_of_nuhost (nuhost cli))) 
                  command [target] (Some text)
            with Not_found ->
              reply cli "401" ~args:[target] "No such nick/channel"
          end
    | (None, "MOTD", [], None) ->
        reply cli "422" "MOTD File is missing"
    | (None, "LUSERS", [], None) ->
        ()
    | (None, "VERSION", [], None) ->
        reply cli "351" ~args:[Irc.version; !(Irc.name)] ""
    | (None, "STATS", [], None) ->
        ()
    | (None, "TIME", [], None) ->
        let now = Unix.gmtime (Unix.time ()) in
        let timestr =
          Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
            (now.Unix.tm_year + 1900)
            now.Unix.tm_mday
            (match now.Unix.tm_mon with
               | 0 -> 12
               | mon -> mon)
            now.Unix.tm_hour
            now.Unix.tm_min
            now.Unix.tm_sec
        in
          reply cli "391" ~args:[!(Irc.name)] timestr;
    | (None, "ADMIN", [], None) ->
        ()
    | (None, "INFO", [], None) ->
        reply cli "371" (Printf.sprintf "pgircd v%s" Irc.version);
        reply cli "371" (Printf.sprintf "Running since %f" Irc.start_time);
        reply cli "374" "End of INFO list"
    | (None, "SERVLIST", [], None) ->
        ()
    | (None, "SQUERY", [servicename], Some text) ->
        ()
    | (None, "WHO", [], None) ->
        ()
    | (None, "WHO", [mask], None) ->
        ()
    | (None, "WHO", [mask; "o"], None) ->
        ()
    | (None, "WHIOS", [masks], None) ->
        ()
    | (None, "KILL", [nickname; comment], None) ->
        ()
    | (None, "PING", [], Some text)
    | (None, "PING", [text], None) ->
        write cli (Some !(Irc.name)) "PONG" [!(Irc.name)] (Some text)
    | (None, "PONG", [payload], None) ->
        (* We do nothing. *)
        ()
    | (None, "ERROR", [], Some message) ->
        write cli (Some !(Irc.name)) "NOTICE" [!(cli.nick)] (Some "Bummer.")
    | (None, "AWAY", [], None) ->
        cli.away := None;
        reply cli "305" "You are no longer marked as being away"
    | (None, "AWAY", [], Some message) ->
        cli.away := Some message;
        reply cli "306" "You have been marked as being away"
    | (None, "REHASH", [], None) ->
        ()
    | (None, "WALLOPS", [], Some text) ->
        ()
    | (None, "ISON", nicks, None) ->
	let ison = List.filter (Hashtbl.mem by_nick) nicks in
	  reply cli "303" (String.concat " " ison)
    | (_, name, _, _) ->
        reply cli "421" ~args:[name] "Unknown or misconstructed command"

let set_nick cli nick =
  if Hashtbl.mem by_nick nick then
    raise (error "433" [nick] "Nickname in use");
  Hashtbl.remove by_nick !(cli.nick);
  Hashtbl.replace by_nick nick cli;
  cli.nick := nick

let rec handle_command_prereg (nick, username, realname, password) iobuf cmd =
  (* Handle a command during the login phase *)
  let acc =
    match (Command.as_tuple cmd) with
      | (None, "PASS", [password'], None) ->
          (nick, username, realname, Some password')
      | (None, "USER", [username'; _; _], Some realname') ->
          (nick, Some username', Some (Irc.truncate realname' 40), password)
      | (None, "NICK", [nick'], None) ->
          (Some nick', username, realname, password)
      | _ ->
          Iobuf.write iobuf (Command.create
                               (Some !(Irc.name)) 
                               "451" ["*"] 
                               (Some "Register first."));
          (nick, username, realname, password)
  in
  let welcome cli =
    try
      set_nick cli !(cli.nick);
      reply cli "001" "Welcome to IRC.";
      reply cli "002" ("I am " ^ !(Irc.name) ^ 
                         " Running version " ^ Irc.version);
      reply cli "003" ("This server was created " ^ 
                         (string_of_float Irc.start_time));
      reply cli "004" (!(Irc.name) ^
                         " " ^ Irc.version ^
                         " " ^ modes ^
                         " " ^ Channel.modes);
      Iobuf.bind iobuf (handle_command cli) (handle_error cli)
    with Error cmd ->
      Iobuf.write iobuf cmd
  in
  match acc with
    | (Some nick, Some username, Some realname, None) ->
        welcome {iobuf = iobuf;
                 nick = ref nick;
                 away = ref None;
                 username = username;
                 realname = realname}
    | (Some nick, Some username, Some realname, Some password) ->
        Iobuf.write iobuf (Command.create
                             (Some !(Irc.name))
                             "NOTICE" ["AUTH"]
                             (Some "*** Authentication unimplemented"));
        welcome {iobuf = iobuf;
                 nick = ref nick;
                 away = ref None;
                 username = username;
                 realname = realname}
    | _ ->
        Iobuf.bind iobuf (handle_command_prereg acc) (fun _ _ -> ())

let handle_connection d fd addr =
  let handle_command = handle_command_prereg (None, None, None, None) in
    Iobuf.create d fd addr handle_command (fun _ _ -> ())