talircd/lib/server/connection.ml

open! Import
open Result_syntax

include (val Logging.sublogs logger "Connection")

type t = {
  router : Router.t;
  server_info : Server_info.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 ~server_info ~addr = {
  router;
  server_info;
  addr;
  outbox = Outbox.make ();
  user = None;
  pending_nick = None;
  pending_userinfo = None;
}

let outbox t = t.outbox


(* numeric replies *)

type reply = string * string list

type 'a result = ('a, reply) Result.t

let reply t (num, params) =
  let prefix = Server_info.prefix t.server_info 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 tryagain cmd          = "263", [cmd; "Please wait a while and try again."]
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)"]
let modeunknownflag       = "501", ["Didn't understand MODE command"]
let usersdontmatch_set    = "502", ["Can't change mode for other users"]
let usersdontmatch_get    = "502", ["Can't view mode for other users"]

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


(* modes *)

let set_user_mode ?(add = Irc.Mode.Set.empty) ?(rem = Irc.Mode.Set.empty) user =
  let mode, chg =
    Irc.Mode.Set.normalize
      (User.mode user)
      { add = Irc.Mode.Set.remove `o add; rem }
  in
  if chg <> Irc.Mode.Set.no_change then
    let modestr = Fmt.str "%a" Irc.Mode.Set.pp_change chg in
    let msg = Irc.Msg.make "MODE" [User.nick user; modestr] in
    begin
      Router.relay msg ~from:user [`to_self];
      User.set_mode user mode;
    end

let set_chan_mode ~from ?(add = Irc.Mode.Set.empty) ?(rem = Irc.Mode.Set.empty) chan =
  let mode, chg =
    Irc.Mode.Set.normalize
      (Chan.mode chan)
      { add; rem }
  in
  if chg <> Irc.Mode.Set.no_change then
    let modestr = Fmt.str "%a" Irc.Mode.Set.pp_change chg in
    let msg = Irc.Msg.make "MODE" [Chan.name chan; modestr] in
    begin
      Router.relay msg ~from [`to_chan chan; `to_self];
      Chan.set_mode chan mode;
    end

let set_chan_key chan ~from = function
  | `set key ->
    let msg = Irc.Msg.make "MODE" [Chan.name chan; "+k"; key] ~always_trailing:true in
    begin
      Router.relay msg ~from [`to_chan chan; `to_self];
      Chan.set_key chan (Some key);
    end
  | `unset ->
    if Chan.key chan <> None then
      let msg = Irc.Msg.make "MODE" [Chan.name chan; "-k"; "*"] in
      begin
        Router.relay msg ~from [`to_chan chan; `to_self];
        Chan.set_key chan None;
      end

let set_chan_limit chan ~from = function
  | `set lim ->
    if Chan.limit chan <> Some lim then
      let msg = Irc.Msg.make "MODE" [Chan.name chan; "+l"; string_of_int lim] in
      begin
        Router.relay msg ~from [`to_chan chan; `to_self];
        Chan.set_limit chan (Some lim);
      end
  | `unset ->
    if Chan.limit chan <> None then
      let msg = Irc.Msg.make "MODE" [Chan.name chan; "-l"] in
      begin
        Router.relay msg ~from [`to_chan chan; `to_self];
        Chan.set_limit chan None;
      end

let on_get_user_mode user me =
  let* () = if user != me then Error usersdontmatch_get else Ok () in
  Ok [
    "221", [Fmt.str "+%a" Irc.Mode.Set.pp (User.mode me)]
  ]

let on_set_user_mode user me modestr _args =
  let* () = if user == me then Ok () else Error usersdontmatch_set in
  let* chg = try Ok (Irc.Mode.Parse.user_modes modestr)
    with Irc.Mode.Parse.Error ->
      (* TODO: "If one or more modes sent are not implemented on the server, the server
         MUST apply the modes that are implemented, and then send the ERR_UMODEUNKNOWNFLAG
         (501) in reply along with the MODE message." *)
      Error modeunknownflag
  in
  set_user_mode me ~add:chg.add ~rem:chg.rem;
  Ok []

let on_get_chan_mode chan _me =
  let rpls = [
    ["324", [Chan.name chan; Fmt.str "+%a" Irc.Mode.Set.pp (Chan.mode chan)]];

    begin match Chan.limit chan with
      | Some lim -> ["324", [Chan.name chan; "+l"; string_of_int lim]]
      | None -> []
    end;

    (* TODO: only display key if priveledged enough to see it *)
    begin match Chan.key chan with
      | Some key -> ["324", [Chan.name chan; "+k"; key]]
      | None -> []
    end;

    (* TODO: RPL_CREATIONTIME (329) *)
  ] in
  Ok (List.flatten rpls)

let on_set_chan_mode chan me modestr args =
  (* TODO: If <modestring> is given, the user sending the command MUST have appropriate
     channel privileges on the target channel to change the modes given. If a user does
     not have appropriate privileges to change modes on the target channel, the server
     MUST NOT process the message, and ERR_CHANOPRIVSNEEDED (482) numeric is returned. *)
  let _ = me, chan in

  let* chg = try Ok (Irc.Mode.Parse.chan_modes modestr args)
    with Irc.Mode.Parse.Error ->
      (* TODO: "If one or more modes sent are not implemented on the server, the server
         MUST apply the modes that are implemented, and then send the ERR_UMODEUNKNOWNFLAG
         (501) in reply along with the MODE message." *)
      Error modeunknownflag
  in

  set_chan_mode chan ~from:me ~add:chg.chan_modes.add ~rem:chg.chan_modes.rem;
  Option.iter (set_chan_key chan ~from:me) chg.chan_key;
  Option.iter (set_chan_limit chan ~from:me) chg.chan_limit;
  (* TODO: ban/op/voice *)

  Ok []

let on_msg_mode t name args =
  let* me = require_registered t in
  let* on_set, on_get =
    try
      match Irc.name_type name with
      | `nick ->
        let u = Router.find_user t.router name in
        Ok (on_set_user_mode u, on_get_user_mode u)
      | `chan ->
        let c = Router.find_chan t.router name in
        Ok (on_set_chan_mode c, on_get_chan_mode c)
      | `invalid -> raise Not_found
    with Not_found ->
      Error (nosuchnick name)
  in
  let* rpls =
    match args with
    | [] -> on_get me
    | modestr :: args -> on_set me modestr args
  in
  List.iter (reply t) rpls;
  Ok ()


(* messages and channels *)

let on_msg_privmsg t name txt =
  let* me = require_registered t in
  let* tgt =
    try
      match Irc.name_type name with
      | `chan -> Ok (`chan (Router.find_chan t.router name))
      | _     -> Ok (`user (Router.find_user t.router name))
    with Not_found ->
      Error (nosuchnick name)
  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 name, dst =
    match tgt with
    | `chan c -> Chan.name c, [`to_chan c]
    | `user u -> User.nick u, [`to_user u]
  in
  let msg = Irc.Msg.make "PRIVMSG" [name; 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 *)
         (* ("=", 0x3D) - Public channel. *)
         (* ("@", 0x40) - Secret channel (secret channel mode "+s"). *)
         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 join t user chan =
  begin
    (* TODO: check if already a member *)
    (* TODO: check channel mode +k, +l *)
    let msg = Irc.Msg.make "JOIN" [Chan.name chan] in
    Router.relay msg ~from:user [`to_chan chan; `to_self];

    Router.join chan user;

    if not (Chan.is_registered chan ~router:t.router) then
      begin
        (* TODO: make founder +o / +q etc. *)
        Chan.register chan ~router:t.router;
        set_chan_mode chan ~from:user
          ~add:(Server_info.conf t.server_info).init_cmode;
      end
  end

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);
      Ok (Chan.make ~name)
  in
  join t me chan;
  (* TODO: send channel topic *)
  list_names t chan;
  Ok ()

let part t user chan ~reason =
  let mem = Router.membership chan user in
  begin
    (* edge case: don't relay PART messages if the user is QUIT'ing *)
    (* FIXME: this will need to be changed again to handle KICK, i think *)
    if User.is_registered user ~router:t.router then
      begin
        let always_trailing = Option.is_some reason in
        let reason = Option.to_list reason in
        let msg = Irc.Msg.make "PART" (Chan.name chan :: reason) ~always_trailing in
        Router.relay msg ~from:user [`to_chan chan; `to_self];
      end;

    Router.part mem;

    (* TODO: if user was op then choose a new op? *)

    if Chan.no_members chan then
      begin
        debug (fun m -> m "recycling empty channel %S" (Chan.name chan));
        Chan.unregister chan ~router:t.router;
      end
  end

let on_msg_part t name reason =
  let reason = match reason with
    | [] -> None
    | xs -> Some (String.concat " " xs)
  in
  let* me = require_registered t in
  let* chan =
    try
      match Irc.name_type name with
      | `chan -> Ok (Router.find_chan t.router name)
      | `nick | `invalid -> raise Not_found
    with Not_found ->
      Error (nosuchchannel name)
  in
  try
    part t me chan ~reason;
    Ok ()
  with Not_found ->
    Error (notonchannel name)


(* welcome and quit *)

let about t me =
  let who = Irc.Msg.prefix_string (User.prefix me) in
  let s_hostname = Server_info.hostname t.server_info in
  let s_version = Server_info.version t.server_info in
  let s_created = Server_info.created t.server_info in
  let conf = Server_info.conf t.server_info in
  let modes l = String.of_seq (List.to_seq l |> Seq.map Irc.Mode.to_char) in
  let umodes = modes conf.all_umodes in
  let cmodes = modes conf.all_cmodes in
  let pmodes = modes conf.all_pmodes 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" s_hostname s_version]);
    reply t ("003", [Fmt.str "This server was created %s" s_created]);
    reply t ("004", [s_hostname; s_version; umodes; cmodes; pmodes]);
    reply t ("005", conf.isupport);
  end

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

let welcome t me =
  begin
    about t me;
    motd t;
  end

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

let quit t me ~reason =
  begin
    let msg = Irc.Msg.make "QUIT" [User.nick me; reason] ~always_trailing:true in
    Router.relay msg ~from:me [`to_interested];

    User.unregister me ~router:t.router;
    List.iter
      (part t me ~reason:None)
      (User.channels me);

    t.user <- None
  end

let close ?(reason = "Client closed") t =
  Option.iter (quit t ~reason) t.user;
  Outbox.close t.outbox

let on_msg_quit t reason =
  let reason = match reason with
    | [] -> "Quit"
    | xs -> String.concat " " ("Quit:" :: xs)
  in
  close t ~reason;
  Ok ()


(* user registration *)

let attempt_to_register t =
  match t.pending_nick, t.pending_userinfo with
  | Some nick, Some userinfo ->
    t.pending_nick <- None;
    if not (Router.is_nick_available t.router nick) then
      Error (nicknameinuse nick)
    else
      let me = User.make nick ~userinfo ~outbox:t.outbox in
      User.register me ~router:t.router;
      t.user <- Some me;
      welcome t me;
      set_user_mode me
        ~add:(Server_info.conf t.server_info).init_umode;
      Ok ()
  | _, _ ->
    Ok ()

let user_set_nick t me nick =
  if not (Router.is_nick_available t.router nick) then
    Error (nicknameinuse nick)
  else
    begin
      let msg = Irc.Msg.make "NICK" [nick] in
      Router.relay msg ~from:me [`to_interested];
      User.unregister me ~router:t.router;
      User.set_nick me nick;
      User.register me ~router:t.router;
      Ok ()
    end

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 ->
    user_set_nick t me nick
  | 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


(* 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", reason -> on_msg_quit t reason
  | "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 :: reason when tgt <> "" -> on_msg_part t tgt reason
  | "MODE", tgt :: args when tgt <> "" -> on_msg_mode t tgt args
  | ("USER" | "JOIN" | "NAMES" | "PART" | "MODE") 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 ->
       trace (fun m -> m "@[%a:@ %a@]" pp_sockaddr t.addr pp_args args);
       match dispatch t args with
       | Ok () -> ()
       | Error err -> reply t err)