talircd/lib/server/connection.ml

open! Import
module User = Router.User

type t = {
  addr : sockaddr;
  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 ~router ~hostname ~outbox in
  { addr; user; outbox; pending_nick = None }

let outbox t = t.outbox

let shutdown t =
  User.quit t.user;
  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 with
      | `nick_in_use -> `nicknameinuse nick
      | `nick_set ->
        let send_mode () =
          Outbox.send t.outbox
            (Irc.Msg.make "MODE" [nick; Fmt.str "+%a" Irc.Mode.pp t.user.mode]
               ~prefix:(User.prefix t.user));
        in
        Lwt.on_success (Lwt.pause ()) send_mode;
        `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 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 msg _ =
  match Router.find_user t.user.router tgt with
  | None -> `nosuchnick tgt
  | Some dst -> Router.privmsg t.user (`user dst) msg; `ok

let on_msg_join t tgt _ =
  Outbox.send t.outbox
    (Irc.Msg.make "JOIN" [tgt] ~prefix:(User.prefix t.user));
  `names ("@", tgt, ["@", User.nick t.user; "", "moe"; "", "barry"])

let on_msg_privmsg t tgt msg = require_registered t (on_msg_privmsg t tgt msg)
let on_msg_join t tgt = require_registered t (on_msg_join t tgt)
    
(* > 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_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", username :: modestr :: _host :: realname :: _ ->
      on_msg_user t username modestr realname
    | "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
    | "USER", _ | "JOIN", _ -> `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
  | `notexttosend -> err_notexttosend t
  | `notregistered -> err_notregistered t
  | `unknowncommand -> err_unknowncommand t msg.command
  | `nonicknamegiven -> err_nonicknamegiven t
  | `erroneusnickname n -> err_erroneousnickname t n