talircd/lib/server/connection.ml

open! Import
module User = Router.User
module Chan = Router.Chan

type t = {
  addr : sockaddr;
  router : Router.t;
  user : User.t;
  outbox : Outbox.t;
  mutable pending_nick : string option;
}

let make ~(router : Router.t) ~(addr : sockaddr) : t =
  let hostname = match addr with
    | ADDR_INET (ia, _) -> Unix.string_of_inet_addr ia
    | ADDR_UNIX path -> path
  in
  let outbox = Outbox.make () in
  let user = User.make ~hostname ~outbox in
  { addr; router; user; outbox; pending_nick = None }

let outbox t = t.outbox

let shutdown t =
  User.quit t.user ~router:t.router;
  Outbox.close t.outbox

(* message handling *)

let require_registered t f =
  if User.is_registered t.user then
    f (Option.get t.user.userinfo)
  else
    `notregistered

(* > user registration *)

let attempt_to_register t =
  match t.pending_nick, t.user.userinfo with
  | Some nick, Some _userinfo ->
    t.pending_nick <- None;
    begin match User.set_nick t.user nick ~router:t.router with
      | `nick_in_use -> `nicknameinuse nick
      | `nick_set ->
        let mode_str = Fmt.str "+%a" Irc.Mode.pp t.user.mode in
        let mode_msg = Irc.Msg.make "MODE" [nick; mode_str] in
        defer (fun () -> Router.relay mode_msg ~from:t.user `to_self);
        `welcome
    end
  | _, _ -> `ok

let on_msg_nick t nick =
  if Irc.name_type nick <> `nick then
    (if nick = "" then `nonicknamegiven else `erroneusnickname nick)
  else if User.is_registered t.user then
    match User.set_nick t.user nick ~router:t.router with
    | `nick_in_use -> `nicknameinuse nick
    | `nick_set ->
      ((* TODO: relay NICK message *));
      `ok
  else begin
    t.pending_nick <- Some nick;
    attempt_to_register t
  end

let on_msg_user t username modestr realname =
  if User.is_registered t.user then
    `alreadyregistered
  else begin
    (* NB: "+iw" is automatically set, so it's impossible to actually affect the initial
       mode with the parameter to USER *)
    ignore modestr;
    t.user.userinfo <- Some { username; realname };
    attempt_to_register t
  end

(* > messages and channels *)

let on_msg_privmsg t tgt txt _ =
  let msg = Irc.Msg.make "PRIVMSG" [tgt; txt] in
  let dst =
    try
      match Irc.name_type tgt with
      | `chan -> `to_chan (Router.find_chan t.router tgt)
      | `nick -> `to_user (Router.find_user t.router tgt)
      | `invalid -> `not_found
    with Not_found -> `not_found
  in
  match dst with
  | `not_found -> `nosuchnick tgt
  | (`to_user _ | `to_chan _) as dst ->
    Router.relay msg ~from:t.user dst;
    `ok

let list_names chan =
  let names =
    List.map
      (fun u -> "", User.nick u)
      (Chan.members chan)
  in
  `names ("@", Chan.name chan, names)

let on_msg_join t name _ =
  match Irc.name_type name with
  | `nick | `invalid ->
    if name = "" then `needmoreparams else `nosuchchannel name
  | `chan ->
    let chan = try Router.find_chan t.router name
      with Not_found ->
        Logs.debug (fun m -> m "making new channel %S" name);
        let chan = Chan.make ~name in
        (* TODO: op user after joining *)
        Chan.register chan ~router:t.router;
        chan
    in
    if not (Chan.is_member chan t.user) then begin
      Chan.join chan t.user;
      let join_msg = Irc.Msg.make "JOIN" [name] in
      Router.relay join_msg ~from:t.user `to_self;
      Router.relay join_msg ~from:t.user (`to_chan chan);
    end;
    list_names chan

let on_msg_names t name _ =
  match Irc.name_type name with
  | `nick | `invalid ->
    if name = "" then `needmoreparams else `nosuchchannel name
  | `chan ->
    let chan = try Some (Router.find_chan t.router name)
      with Not_found -> None
    in
    match chan with
    | None -> `nosuchchannel name
    | Some chan -> list_names chan

let on_msg_privmsg t tgt msg = require_registered t (on_msg_privmsg t tgt msg)
let on_msg_join t name = require_registered t (on_msg_join t name)
let on_msg_names t name = require_registered t (on_msg_names t name)
    
(* > misc *)

let on_msg_quit t why =
  let why = String.concat " " why in
  Logs.debug (fun m -> m "%a: quit: %S" pp_sockaddr t.addr why);
  `quit

(* message sending *)

(* TODO: configure these *)
let srv_host = "irc.tali.software"
let srv_ver = "0.0.0"
let srv_created = "Sun Jan 7 09:58:24 PM EST 2024"
let srv_isupport = [
  "CASEMAPPING=ascii";
  "CHANTYPES=#";
  "PREFIX=(ov)@+";
]
let srv_motd_lines = [
  "MEOW MEOW MEOW MEOW MEOW";
  "meow meow meow meow meow";
  "meowmeowmeowmeowmeowmeow";
]

let rpl t cmd params =
  let prefix = Irc.Msg.Server_prefix srv_host in
  let target = User.nick t.user in
  Outbox.send t.outbox (Irc.Msg.make ~prefix cmd (target :: params))

let rpl_tryagain t cmd = rpl t "263" [cmd; "Please wait a while and try again."]

let rpl_welcome t =
  let who = Irc.Msg.prefix_string (User.prefix t.user) in
  begin
    rpl t "001" [Fmt.str "Welcome to the tali IRC network %s" who];
    rpl t "002" [Fmt.str "Your host is %s, running version %s" srv_host srv_ver];
    rpl t "003" [Fmt.str "This server was created %s" srv_created];
    rpl t "004" [srv_host; srv_ver; "aiwroOs"; "oinvm"];
    rpl t "005" (srv_isupport @ ["are supported by this server"]);
  end

let rpl_motd t =
  begin 
    rpl t "375" [Fmt.str "- %s Message of the day - " srv_host];
    List.iter (fun ln -> rpl t "372" ["- " ^ ln]) srv_motd_lines;
    rpl t "376" ["End of /MOTD command"];
  end

let rpl_names t chan_prefix chan users =
  begin
    List.iter (fun (up, u) -> rpl t "353" [chan_prefix; chan; up ^ u]) users;
    rpl t "366" [chan; "End of NAMES list"]
  end

let err_nosuchnick t tgt = rpl t "401" [tgt; "No such nick/channel"]
let err_nosuchchannel t tgt = rpl t "403" [tgt; "No such channel"]
let err_norecipient t cmd = rpl t "411" [Fmt.str "No recipient given (%s)" cmd]
let err_notexttosend t = rpl t "412" ["No text to send"]
let err_unknowncommand t cmd = rpl t "421" [cmd; "Unknown command"]
let err_nonicknamegiven t = rpl t "431" ["No nickname given"]
let err_erroneousnickname t nick = rpl t "432" [nick; "Erroneus nickname"]
let err_nicknameinuse t nick = rpl t "433" [nick; "Nickname is already in use"]
let err_notregistered t = rpl t "451" ["You have not registered"]
let err_needmoreparams t cmd = rpl t "461" [cmd; "Not enough parameters"]
let err_alreadyregistered t = rpl t "462" ["Unauthorized command (already registered)"]

(* message parsing *)

let on_msg t (msg : Irc.Msg.t) : unit =
  (* Logs.debug (fun m -> m "%a: %a" pp_sockaddr t.addr Irc.Msg.pp msg); *)
  let result =
    match msg.command, msg.params with
    | "NICK", new_nick :: _ -> on_msg_nick t new_nick
    | "NICK", [] -> `nonicknamegiven
    | "USER", u :: m :: _h :: r :: _ -> on_msg_user t u m r
    | "USER", _ -> `needmoreparams
    | "QUIT", why -> on_msg_quit t why
    | "MOTD", _ -> `motd
    | "PRIVMSG", tgt :: msg :: _ -> on_msg_privmsg t tgt msg
    | "PRIVMSG", [_] -> `notexttosend | "PRIVMSG", [] -> `norecipient
    | "JOIN", tgt :: _ -> on_msg_join t tgt
    | "JOIN", _ -> `needmoreparams
    | "NAMES", tgt :: _ -> on_msg_names t tgt
    | "NAMES", _ -> `needmoreparams
    | _, _ -> `unknowncommand
  in
  match result with
  | `ok -> ()
  | `quit -> shutdown t
  | `welcome -> rpl_welcome t; rpl_motd t
  | `motd -> rpl_motd t
  | `names (cp, ch, us) -> rpl_names t cp ch us
  | `tryagain -> rpl_tryagain t msg.command
  | `alreadyregistered -> err_alreadyregistered t
  | `needmoreparams -> err_needmoreparams t msg.command
  | `nicknameinuse n -> err_nicknameinuse t n    
  | `norecipient -> err_norecipient t msg.command
  | `nosuchnick n -> err_nosuchnick t n
  | `nosuchchannel c -> err_nosuchchannel t c
  | `notexttosend -> err_notexttosend t
  | `notregistered -> err_notregistered t
  | `unknowncommand -> err_unknowncommand t msg.command
  | `nonicknamegiven -> err_nonicknamegiven t
  | `erroneusnickname n -> err_erroneousnickname t n