talircd/lib/server/router.ml

type nick_key = Nick_key of string [@@unboxed]
let nick_key n = Nick_key (String.lowercase_ascii n) (* TODO: "scandinavian" lowercase *)
let unset = Nick_key ""

type t = {
  users : (nick_key, user) Hashtbl.t
  (* TODO: channels *)
}

and user = {
  router : t;
  hostname : string;
  mutable key : nick_key;
  mutable nick : Irc.nick;
  mutable userinfo : Irc.userinfo option;
  mutable mode : Irc.Mode.t;
  inbox : Irc.Msg.t Lwt_stream.t;
  push_inbox : (Irc.Msg.t option -> unit);
}

let make () =
  { users = Hashtbl.create 4096 }

let find_user t nick =
  Hashtbl.find_opt t.users (nick_key nick)

module User = struct
  type t = user

  let make router ~hostname =
    let inbox, push_inbox = Lwt_stream.create () in
    {
      router;
      hostname;
      key = unset;
      nick = "*";
      userinfo = None;
      mode = Irc.Mode.of_string "iw";
      inbox; push_inbox;
    }

  let nick t = t.nick
  let prefix t = Irc.Msg.User_prefix (t.nick, t.userinfo, Some t.hostname)

  let inbox t = t.inbox
  let send t msg = try t.push_inbox (Some msg) with Lwt_stream.Closed -> ()
  let close t = try t.push_inbox None with Lwt_stream.Closed -> ()

  let is_registered t = t.key <> unset

  let unregister t =
    Hashtbl.remove t.router.users t.key;
    t.key <- unset

  let set_nick t new_nick =
    let key = nick_key new_nick in
    if Hashtbl.mem t.router.users key then
      `nick_in_use
    else begin
      ((* TODO: relay NICK message *));
      unregister t;
      Hashtbl.add t.router.users key t;
      t.key <- key;
      t.nick <- new_nick;
      `nick_set
    end

  let cleanup t =
    (* TODO: relay QUIT message *)
    unregister t;
    close t
end

let privmsg src dst txt =
  let prefix = User.prefix src in
  match dst with
  | `user dst ->
    let msg = Irc.Msg.make "PRIVMSG" [User.nick dst; txt] ~prefix in
    User.send dst msg