talircd/lib/server/router.ml

open! Import

type t = {
  users : (string_ci, user) Hashtbl.t;
  channels : (string_ci, chan) Hashtbl.t;
}

and user = {
  outbox : Outbox.t;
  userinfo : Irc.userinfo;
  mutable mode : Irc.Mode.Set.t;
  mutable nick : Irc.name;
  mutable nick_key : string_ci;
  mutable membership : membership Dllist.t;
}

and chan = {
  name : Irc.name;
  name_key : string_ci;
  mutable topic : string option;
  mutable members : membership Dllist.t;
}

and membership = {
  mem_user : user;
  mem_chan : chan;
  mutable mem_in_chan : membership Dllist.node option;
  (* mutable mem_of_user : membership Dllist.node option; *)
}

type router = t

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

let find_user t nick =
  Hashtbl.find t.users (string_ci nick)

let find_chan t name =
  Hashtbl.find t.channels (string_ci name)

let user_prefix user =
  Irc.Msg.User_prefix (user.nick, Some user.userinfo)  

let chan_members chan =
  Dllist.fold_r (fun m xs -> m.mem_user :: xs) chan.members []

let user_channels user =
  Dllist.fold_r (fun m xs -> m.mem_chan :: xs) user.membership []

let relay ~(from : user) (msg : Irc.Msg.t) tgts =
  let msg =
    if msg.prefix = No_prefix then
      { msg with prefix = user_prefix from }
    else msg
  in
  let bcc u = Outbox.Bcc.add u.outbox in
  let bcc_not_self u = if u != from then bcc u in
  let bcc_channel c = List.iter bcc_not_self (chan_members c) in
  List.iter
    (function
      | `to_self -> bcc from
      | `to_user tgt -> bcc tgt
      | `to_chan tgt -> bcc_channel tgt
      | `to_interested -> bcc from; List.iter bcc_channel (user_channels from))
    tgts;
  Outbox.Bcc.send_all msg

(* TODO: split out [User] and [Chan] into separate files *)


module User = struct
  type t = user

  let make ~userinfo ~outbox =
    {
      outbox;
      userinfo;
      nick = "*";
      nick_key = empty_string_ci;
      mode = Irc.Mode.Set.of_list [`i; `w];
      membership = Dllist.create ();
    }

  let outbox t = t.outbox
  let nick t = t.nick
  let mode t = t.mode
  let channels = user_channels
  let prefix = user_prefix
  (* let is_registered t = t.nick_key <> empty_string_ci *)

  let unregister t ~router =
    Hashtbl.remove router.users t.nick_key;
    t.nick_key <- empty_string_ci

  let set_nick ?(success_callback = ignore) t new_nick ~router =
    let key = string_ci new_nick in
    if Hashtbl.mem router.users key then
      `nick_in_use
    else begin
      (* hack to allow broadcasting a NICK message before nick is actually changed *)
      success_callback ();
      unregister t ~router;
      Hashtbl.add router.users key t;
      t.nick <- new_nick;
      t.nick_key <- key;
      `nick_set
    end

  let set_mode t new_mode =
    t.mode <- new_mode

  let rec part_all t =
    (* List.iter (fun c -> Chan.part c t) (channels t) *)
    match Dllist.take_l t.membership with
    | m ->
      Option.iter Dllist.remove m.mem_in_chan;
      part_all t
    | exception Dllist.Empty ->
      ()
end


module Chan = struct
  type t = chan

  let make ~name =
    {
      name;
      name_key = string_ci name;
      topic = None;
      members = Dllist.create ();
    }

  let name t = t.name
  let topic t = t.topic
  let members = chan_members
  let no_members t = Dllist.is_empty t.members

  let register t ~router =
    Hashtbl.replace router.channels t.name_key t

  let unregister t ~router =
    Hashtbl.remove router.channels t.name_key

  let is_member t user =
    let is_mem m = m.mem_chan == t in
    try
      ignore (Dllist.find_node_l is_mem user.membership);
      true
    with Not_found ->
      false

  let join t user =
    let m = {
      mem_chan = t;
      mem_user = user;
      mem_in_chan = None;
    } in
    begin
      m.mem_in_chan <- Some (Dllist.add_r m t.members);
      ignore (Dllist.add_r m user.membership);
    end

  let part t user =
    let is_mem m = m.mem_chan == t in
    let mem = Dllist.find_node_l is_mem user.membership in
    Option.iter Dllist.remove (Dllist.get mem).mem_in_chan;
    Dllist.remove mem
end