talircd/lib/server/connection.ml

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

include (val Logging.sublogs logger "Connection")

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

let make ~(router : Router.t) ~(addr : sockaddr) : t =
  let outbox = Outbox.make () in
  { router; addr; outbox; user = None; pending_nick = None; pending_userinfo = None }

let outbox t = t.outbox

let shutdown ?reason t =
  Option.iter
    (fun me ->
       let reason = Option.value reason ~default:"Goot bye" in
       Router.relay (Irc.Msg.make "QUIT" [reason]) ~from:me (`to_interested me);
       User.part_all me;
       (* TODO: BUG: unregister empty channels *)
       User.unregister me ~router:t.router)
    t.user;
  Outbox.close t.outbox


(* 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_motd_lines = [
  "MEOW MEOW MEOW MEOW MEOW";
  "meow meow meow meow meow";
  "meowmeowmeowmeowmeowmeow";
]


(* numeric replies *)

type reply = string * string list

let reply t (num, params) =
  let prefix = Irc.Msg.Server_prefix srv_host in
  let target = match t.user with
    | Some me -> User.nick me
    | None -> "*"
  in
  Outbox.send t.outbox
    (Irc.Msg.make ~prefix num (target :: params))

let welcome t me =
  let who = Irc.Msg.prefix_string (User.prefix me) in
  begin
    reply t ("001", [Fmt.str "Welcome to the tali IRC network %s" who]);
    reply t ("002", [Fmt.str "Your host is %s, running version %s" srv_host srv_ver]);
    reply t ("003", [Fmt.str "This server was created %s" srv_created]);
    reply t ("004", [srv_host; srv_ver; "iow"; "imnst"; "bklov"]);
    reply t ("005", ["CASEMAPPING=ascii";
                     "CHANTYPES=#";
                     "CHANMODES=b,k,l,imstn";
                     "PREFIX=(ov)@+";
                     "are supported by this server"]);
  end

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

(* errors *)

let nosuchnick tgt        = "401", [tgt; "No such nick/channel"]
let nosuchchannel tgt     = "403", [tgt; "No such channel"]
let norecipient           = "411", ["No recipient given (PRIVMSG)"]
let notexttosend          = "412", ["No text to send"]
let unknowncommand cmd    = "421", [cmd; "Unknown command"]
let nonicknamegiven       = "431", ["No nickname given"]
let erroneusnickname nick = "432", [nick; "Erroneus nickname"]
let nicknameinuse nick    = "433", [nick; "Nickname is already in use"]
let notonchannel chan     = "442", [chan; "You're not on that channel"]
let notregistered         = "451", ["You have not registered"]
let needmoreparams cmd    = "461", [cmd; "Not enough parameters"]
let alreadyregistered     = "462", ["Unauthorized command (already registered)"]


(* user registration *)

let require_registered t =
  match t.user with
  | Some me -> Ok me
  | None -> Error notregistered

let attempt_to_register t =
  match t.pending_nick, t.pending_userinfo with
  | Some nick, Some userinfo ->
    t.pending_nick <- None;
    let me = User.make ~userinfo ~outbox:t.outbox in
    begin match User.set_nick me nick ~router:t.router with
      | `nick_in_use -> Error (nicknameinuse nick)
      | `nick_set ->
        t.user <- Some me;
        welcome t me;
        motd t;
        (* TODO: get "actual" user mode *)
        let msg = Irc.Msg.make "MODE" [nick; "+iw"] in
        Router.relay msg ~from:me `to_self;
        Ok ()
    end
  | _, _ ->
    Ok ()

let on_msg_nick t nick =
  let* () =
    match Irc.name_type nick with
    | `nick -> Ok ()
    | `chan | `invalid -> Error (erroneusnickname nick)
  in
  match t.user with
  | Some me ->
    begin
      let msg = Irc.Msg.make "NICK" [nick] in
      match
        User.set_nick me nick
          ~router:t.router
          ~success_callback:(fun () -> Router.relay msg ~from:me (`to_interested me))
      with
      | `nick_in_use -> Error (nicknameinuse nick)
      | `nick_set -> Ok ()
    end
  | None ->
    t.pending_nick <- Some nick;
    attempt_to_register t

let on_msg_user t username realname =
  match t.user with
  | Some _me -> Error alreadyregistered
  | None ->
    (* TODO: configure hiding hostnames *)
    let hostname = match t.addr with
      | ADDR_INET (ia, _) -> Unix.string_of_inet_addr ia
      | ADDR_UNIX path    -> path
    in
    t.pending_userinfo <- Some { username; realname; hostname };
    attempt_to_register t


(* messages and channels *)

let on_msg_privmsg t tgt txt =
  let* me = require_registered t in
  let* dst =
    try
      match Irc.name_type tgt with
      | `chan -> Ok (`to_chan (Router.find_chan t.router tgt))
      | _     -> Ok (`to_user (Router.find_user t.router tgt))
    with Not_found ->
      Error (nosuchnick tgt)
  in
  (* TODO: check if user is away *)
  (* TODO: check if channel is +n and user is not a member *)
  (* TODO: check if channel is +m and user is not priviledged *)
  (* TODO: check if channel is +b <user> *)
  let msg = Irc.Msg.make "PRIVMSG" [tgt; txt] ~always_trailing:true in
  Router.relay msg ~from:me dst;
  Ok ()

let list_names t chan =
  begin
    List.iter
      (fun user ->
         (* TODO: check if user is +i and not in channel with them *)
         reply t ("353", ["@"; Chan.name chan; User.nick user]))
      (Chan.members chan);
    reply t ("366", [Chan.name chan; "End of NAMES list"])
  end

let on_msg_names t name =
  let* _me = require_registered t in
  let* chan =
    try
      match Irc.name_type name with
      | `chan -> Ok (Router.find_chan t.router name)
      | _     -> Error (nosuchchannel name)
    with Not_found ->
      Error (nosuchchannel name)
  in
  (* TODO: check if channel is +s and user not member of channel *)
  list_names t chan;
  Ok ()

let on_msg_join t name =
  let* me = require_registered t in
  (* TODO: keys parameter *)
  (* TODO: "0" parameter means part from all channels *)
  let* chan =
    try
      match Irc.name_type name with
      | `chan -> Ok (Router.find_chan t.router name)
      | _     -> Error (nosuchchannel name)
    with Not_found ->
      debug (fun m -> m "making new channel %S" name);
      let chan = Chan.make ~name in
      Chan.register chan ~router:t.router;
      (* TODO: make user +o *)
      Ok chan
  in
  (* TODO: check if channel is +k *)
  Chan.join chan me;
  let msg = Irc.Msg.make "JOIN" [name] in
  Router.relay msg ~from:me `to_self;
  Router.relay msg ~from:me (`to_chan chan);
  (* TODO: send channel topic *)
  list_names t chan;
  Ok ()

let on_msg_part t name =
  let* me = require_registered t in
  (* TODO: part reason *)
  let* chan =
    try
      match Irc.name_type name with
      | `chan -> Ok (Router.find_chan t.router name)
      | `nick | `invalid -> Error (nosuchchannel name)
    with Not_found ->
      Error (nosuchchannel name)
  in
  let* () = if Chan.is_member chan me then Ok () else Error (notonchannel name) in
  let msg = Irc.Msg.make "PART" [name] in
  Router.relay msg ~from:me `to_self;
  Router.relay msg ~from:me (`to_chan chan);
  Chan.part chan me;
  if Chan.no_members chan then begin
    debug (fun m -> m "recycling channel %S" name);
    Chan.unregister chan ~router:t.router;
  end;
  Ok ()


(* misc *)

let on_msg_motd t =
  let* _me = require_registered t in
  motd t;
  Ok ()

let on_msg_quit t reason =
  (* TODO: '''When connections are terminated by a client-sent QUIT command, servers
     SHOULD prepend <reason> with the ASCII string "Quit: " when sending QUIT messages to
     other clients''' *)
  let reason = String.concat " " reason in
  shutdown t ~reason;
  Ok ()


(* message parsing *)

let dispatch t = function
  | "NICK", nick :: _ when nick <> "" -> on_msg_nick t nick
  | "NICK", _ -> Error nonicknamegiven
  | "USER", unm :: _ :: _ :: rnm :: _ -> on_msg_user t unm rnm
  | "QUIT", why -> on_msg_quit t why
  | "MOTD", _ -> on_msg_motd t
  | "PRIVMSG", ([] | "" :: _) -> Error norecipient
  | "PRIVMSG", ([_] | _ :: "" :: _) -> Error notexttosend
  | "PRIVMSG", tgt :: msg :: _ -> on_msg_privmsg t tgt msg
  | "JOIN", tgt :: _ when tgt <> "" -> on_msg_join t tgt
  | "NAMES", tgt :: _ when tgt <> "" -> on_msg_names t tgt
  | "PART", tgt :: _ when tgt <> "" -> on_msg_part t tgt
  | ("USER" | "JOIN" | "NAMES" | "PART") as cmd, _ ->
    Error (needmoreparams cmd)
  | cmd, _ ->
    Error (unknowncommand cmd)

let split_command_params cmd params =
  match cmd, params with
  | ("PRIVMSG" | "JOIN" | "NAMES" | "PART"), tgts :: rest
    when String.contains tgts ',' ->
    (* TODO: "JOIN" should be handled specially *)
    String.split_on_char ',' tgts |>
    List.map (fun tgt -> cmd, tgt :: rest)
  | _ ->
    [cmd, params]

let pp_args ppf (cmd, params) =
  Fmt.pf ppf "@[%s@ %a@]" cmd (Fmt.list (Fmt.fmt "%S") ~sep:Fmt.sp) params

let on_msg t (msg : Irc.Msg.t) : unit =
  split_command_params msg.command msg.params |>
  List.iter
    (fun args ->
       debug (fun m -> m "@[%a:@ %a@]" pp_sockaddr t.addr pp_args args);
       match dispatch t args with
       | Ok () -> ()
       | Error err -> reply t err)