talircd/lib/server/connection.ml

open! Import
open Result_syntax
open Router_types

include (val Logging.sublogs logger "Connection")

let _todo_validation_please x = x

type t = {
  router : Router.t;
  server_info : Server_info.t;
  addr : sockaddr;
  outbox : Outbox.t;
  mutable activity : activity_state;
  mutable user : user option;
  mutable pending_nick : name option;
  mutable pending_userinfo : userinfo option;
}

and activity_state =
  (* enters this state whenever the client interacts with the server *)
  | Active
  (* enters this state after the ping interval has elapsed *)
  | Inactive
  (* enters this after the ping interval has elapsed again. the client
     must respond with a PONG within the next interval or else the connection
     will be closed *)
  | Pinged of string

let make ~router ~server_info ~addr = {
  router;
  server_info;
  addr;
  outbox = Outbox.make ();
  user = None;
  pending_nick = None;
  pending_userinfo = None;
  activity = Active;
}

let outbox t = t.outbox


(* numeric replies *)

type reply = string * string list

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

let ( >>= ) = Result.bind

let list_of_errors = function
  | Ok () -> []
  | Error e -> [e]

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
  let always_trailing = match num with
    | "256" | "301" | "302" | "311" | "312" | "314" | "319" | "332"
    | "353" -> true
    | _ -> false
  in
  Outbox.send t.outbox
    (Msg.make num (target :: params)
       ~prefix ~always_trailing)

let away nick text        = "301", [nick; text]
let nosuchnick tgt        = "401", [tgt; "No such nick/channel"]
let nosuchchannel tgt     = "403", [tgt; "No such channel"]
let cannotsendtochan tgt  = "404", [tgt; "Cannot send to channel"]
let norecipient cmd       = "411", [Fmt.str "No recipient given (%s)" cmd]
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 usernotinchannel n c  = "442", [n; c; "They aren't on that channel"]
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 channelisfull chan    = "471", [chan; "Cannot join channel (+l)"]
let unknownmode chr       = "472", [String.make 1 chr; "is an unknown mode char to me"]
let noprivileges          = "481", ["Permission Denied- You're not an IRC operator"]
let chanoprivsneeded chan = "482", [chan; "You're not channel operator"]
let umodeunknownflag      = "501", ["Unknown MODE flag"]
let usersdontmatch x      = "502", [Fmt.str "Can't %s mode for other users" x]


(* permission checking *)

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

let require_membership chan me =
  match Router.membership chan me with
  | mem -> Ok mem
  | exception Not_found -> Error (notonchannel (Chan.name chan))

let require_chan_op mem =
  match mem.mem_priv with
  | Operator -> Ok ()
  | _ -> Error (chanoprivsneeded (Chan.name mem.mem_chan))


(* modes *)

let set_user_mode ?(add = Mode.Set.empty) ?(rem = Mode.Set.empty) user =
  let mode, chg =
    Mode.Set.normalize
      (User.mode user)
      { add = Mode.Set.remove `o add; rem }
  in
  if chg <> Mode.Set.no_change then
    let modestr = Fmt.str "%a" Mode.Set.pp_change chg in
    let msg = 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 = Mode.Set.empty) ?(rem = Mode.Set.empty) chan =
  let mode, chg =
    Mode.Set.normalize
      (Chan.mode chan)
      { add; rem }
  in
  if chg <> Mode.Set.no_change then
    let modestr = Fmt.str "%a" Mode.Set.pp_change chg in
    let msg = Msg.make "MODE" [Chan.name chan; modestr] in
    Router.relay msg ~from [`to_chan chan; `to_self];
    Chan.set_mode chan mode

let set_chan_key chan ~from chg =
  let key, args = match chg with
    | `set k -> Some k, ["+k"; k]
    | `unset -> None,   ["-k"]
  in
  if key <> Chan.key chan then
    let always_trailing = Option.is_some key in
    let msg = Msg.make "MODE" (Chan.name chan :: args) ~always_trailing in
    Router.relay msg ~from [`to_chan chan; `to_self];
    Chan.set_key chan key

let set_chan_limit chan ~from chg =
  let limit, args = match chg with
    | `set l -> Some l, ["+l"; string_of_int l]
    | `unset -> None,   ["-l"]
  in
  if limit <> Chan.limit chan then
    let msg = Msg.make "MODE" (Chan.name chan :: args) in
    Router.relay msg ~from [`to_chan chan; `to_self];
    Chan.set_limit chan limit

let set_member_priv ~from mem priv =
  let user = mem.mem_user in
  let chan = mem.mem_chan in
  let modestr = match mem.mem_priv, priv with
    | _, Voice -> "+v"
    | _, Operator -> "+o"
    | Voice, Normal -> "-v"
    | Operator, Normal -> "-o"
    | _, _ -> ""
  in
  if mem.mem_priv <> priv then
    let msg = Msg.make "MODE" [Chan.name chan; modestr; User.nick user] in
    Router.relay msg ~from [`to_chan chan; `to_self];
    mem.mem_priv <- priv

let on_get_user_mode user me =
  let* () = if user == me then Ok () else Error (usersdontmatch "get") in
  Ok [
    "221", [Fmt.str "+%a" 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 (Mode.Parse.user_modes modestr)
    with Mode.Parse.Unknown_mode _ ->
      (* 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 umodeunknownflag
  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" 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;

    begin match Chan.key chan with
      | Some key ->
        let key = match Router.membership chan me with
          | _is_member -> key
          | exception Not_found -> "*"
        in
        ["324", [Chan.name chan; "+k"; key]]
      | None -> []
    end;

    ["329", [Chan.name chan; Fmt.str "%a" pp_unixtime (Chan.creation_time chan)]];
  ] in
  Ok (List.flatten rpls)

let on_set_chan_mode chan me modestr args ~router =
  let* chg = try Ok (Mode.Parse.chan_modes modestr args)
    with
    | Mode.Parse.Missing_args ->
      Error (needmoreparams "MODE")
    | Mode.Parse.Unknown_mode ch ->
      Error (unknownmode ch)
      (* TODO: ERR_INVALIDMODEPARAM (696)
         "<client> <target chan/user> <mode char> <parameter> :<description>" *)
  in

  let* mem = require_membership chan me in
  let* () = require_chan_op mem 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: MODE <chan> +b *)

  let results =
    List.map
      (fun (dir, mode, nick) ->
         let* user = try Ok (Router.find_user router nick)
           with Not_found -> Error (nosuchnick nick) in
         let* mem = try Ok (Router.membership chan user)
           with Not_found -> Error (usernotinchannel (User.nick user) (Chan.name chan)) in
         let priv : Router.priv = match mode with
           | `o -> Operator
           | `v -> Voice
         in
         begin match dir with
           | `add -> set_member_priv mem priv ~from:me
           | `rem -> if mem.mem_priv = priv then set_member_priv mem Normal ~from:me
         end;
         Ok ())
      chg.chan_privs
  in

  Ok (List.flat_map list_of_errors results)

let on_msg_mode t name args =
  let* me = require_registered t in
  let* on_set, on_get =
    try
      match 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 ~router:t.router, 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 *)

let get_priv_opt chan user =
  try
    let mem = Router.membership chan user in
    Some mem.mem_priv
  with Not_found ->
    None

let send_to_chan ~from chan =
  let priv_required =
    if      Mode.Set.mem `m (Chan.mode chan) then Some Voice
    else if Mode.Set.mem `n (Chan.mode chan) then Some Normal
    else None
  in
  if get_priv_opt chan from < priv_required then
    Error (cannotsendtochan (Chan.name chan))
  else
    Ok (Chan.name chan, [`to_chan chan])

let send_to_user user =
  match User.away user with
  | Some text ->
    Error (away (User.nick user) text)
  | None ->
    Ok (User.nick user, [`to_user user])

let on_msg_privmsg ?(cmd = "PRIVMSG") t tgt txt =
  let* me = require_registered t in
  let* name, tgts =
    try
      match name_type tgt with
      | `chan -> send_to_chan (Router.find_chan t.router tgt) ~from:me
      | `nick -> send_to_user (Router.find_user t.router tgt)
      | `invalid -> raise Not_found
    with Not_found ->
      Error (nosuchnick tgt)
  in
  let msg = Msg.make cmd [name; txt] ~always_trailing:true in
  Router.relay msg ~from:me tgts;
  Ok ()

let set_away t me status =
  if status <> User.away me then
    begin
      User.set_away me status;
      match status with
      | None -> reply t ("305", ["You are no longer marked as being away"])
      | Some _ -> reply t ("306", ["You have been marked as being away"])
    end

let on_msg_away t status =
  let* me = require_registered t in
  set_away t me status;
  Ok ()


(* channels *)

let membership_prefix = function
  | Normal -> ""
  | Voice -> "+"
  | Operator -> "@"

let is_invisible user =
  Mode.Set.mem `i (User.mode user)

let is_secret chan =
  Mode.Set.mem `s (Chan.mode chan)

let list_names t me chan =
  let members =
    match Router.membership chan me with
    | _is_member -> Chan.membership chan
    | exception Not_found ->
      if is_secret chan then
        []
      else
        Chan.membership_when
          (fun mem -> not (is_invisible mem.mem_user))
          chan
  in
  let nicks =
    List.map
      (fun mem ->
         membership_prefix mem.mem_priv ^ User.nick mem.mem_user)
      members
  in
  let chan_name = Chan.name chan in
  let chan_sym = if is_secret chan then "@" else "=" in
  begin
    (* TODO: concat member names until message becomes too long *)
    List.iter (fun nick -> reply t ("353", [chan_sym; chan_name; nick])) nicks;
    reply t ("366", [chan_name; "End of NAMES list"])
  end

let on_msg_names t name =
  let* me = require_registered t in
  let* chan =
    try
      match name_type name with
      | `chan -> Ok (Router.find_chan t.router name)
      | `nick | `invalid -> raise Not_found
    with Not_found ->
      Error (nosuchchannel name)
  in
  list_names t me chan;
  Ok ()

let get_topic_who_time t chan =
  Option.iter
    (fun (who, time) ->
       reply t ("333", [Chan.name chan; who; Fmt.str "%a" pp_unixtime time]))
    (Chan.topic_who_time chan)

let get_topic ?(reply_if_missing=true) t chan =
  match Chan.topic chan with
  | Some topic ->
    reply t ("332", [Chan.name chan; topic]);
    get_topic_who_time t chan
  | None ->
    if reply_if_missing then
      begin
        reply t ("331", [Chan.name chan; "No topic is set"]);
        get_topic_who_time t chan
      end

let set_topic chan topic =
  Chan.set_topic chan topic

let on_msg_topic t name args =
  let* me = require_registered t in
  let* chan =
    try
      match name_type name with
      | `chan -> Ok (Router.find_chan t.router name)
      | `nick | `invalid -> raise Not_found
    with Not_found ->
      Error (nosuchchannel name)
  in
  let* mem = require_membership chan me in
  match args with
  | [] ->
    get_topic t chan;
    Ok ()
  | args ->
    let* () =
      if Mode.Set.mem `t (Chan.mode chan) then require_chan_op mem
      else Ok ()
    in
    let topic = String.concat " " args in
    let msg = Msg.make "TOPIC" [Chan.name chan; topic] ~always_trailing:true in
    Router.relay msg ~from:me [`to_chan chan; `to_self];
    set_topic chan (if args = [""] then None else Some topic)
      ~who:(User.nick me);
    Ok ()

let join t user chan =
  let msg = Msg.make "JOIN" [Chan.name chan] in
  Router.relay msg ~from:user [`to_chan chan; `to_self];
  let mem = Router.join chan user in
  if not (Chan.is_registered chan ~router:t.router) then
    begin
      Chan.register chan ~router:t.router;
      set_chan_mode chan ~from:user ~add:t.server_info.conf.init_cmode;
      set_member_priv mem ~from:user Operator;
    end

let on_msg_join t name =
  let* me = require_registered t in
  let* chan =
    try
      match name_type name with
      | `chan -> Ok (Router.find_chan t.router name)
      | `nick | `invalid ->
        (* pretend malformed channel name means the channel doesn't exist and
           DON'T try to make a new channel *)
        Error (nosuchchannel name)
    with Not_found ->
      info (fun m -> m "making new channel %S" name);
      Ok (Chan.make name)
  in
  match Router.membership chan me with
  | _already_a_member -> Ok ()
  | exception Not_found ->
    if Chan.is_full chan then
      Error (channelisfull (Chan.name chan))
    else begin
      (* TODO: +k *)
      _todo_validation_please ();
      join t me chan;
      get_topic t chan ~reply_if_missing:false;
      list_names t me chan;
      Ok ()
    end

let leave t mem ~from ~why =
  let user = mem.mem_user in
  let chan = mem.mem_chan in
  begin match why with
    | `quit ->
      (* assume QUIT message has already been relayed *)
      ()
    | `part reason ->
      let always_trailing = Option.is_some reason in
      let params = Chan.name chan :: Option.to_list reason in
      let msg = Msg.make "PART" params ~always_trailing in
      Router.relay msg ~from [`to_chan chan; `to_self]
    | `kick comment ->
      let always_trailing = Option.is_some comment in
      let params = Chan.name chan :: User.nick user :: Option.to_list comment in
      let msg = Msg.make "KICK" params ~always_trailing in
      Router.relay msg ~from [`to_chan chan; `to_self]
  end;
  Router.part mem;
  if Chan.is_empty chan then
    begin
      info (fun m -> m "recycling empty channel %S" (Chan.name chan));
      Chan.unregister chan ~router:t.router;
    end

let on_msg_part t name reason =
  let* me = require_registered t in
  let* chan =
    try
      match name_type name with
      | `chan -> Ok (Router.find_chan t.router name)
      | `nick | `invalid -> raise Not_found
    with Not_found ->
      Error (nosuchchannel name)
  in
  let* mem = try Ok (Router.membership chan me)
    with Not_found -> Error (notonchannel name) in
  leave t mem ~from:me ~why:(`part reason);
  Ok ()

let on_msg_kick t name nick comment =
  let* me = require_registered t in
  let* chan =
    try
      match name_type name with
      | `chan -> Ok (Router.find_chan t.router name)
      | `nick | `invalid -> raise Not_found
    with Not_found ->
      Error (nosuchchannel name)
  in
  let* () = require_membership chan me >>= require_chan_op in
  let* user =
    try
      match name_type nick with
      | `nick -> Ok (Router.find_user t.router nick)
      | `chan | `invalid -> raise Not_found
    with Not_found ->
      Error (nosuchnick name)
  in
  let* mem = try Ok (Router.membership chan user)
    with Not_found ->
      Error (usernotinchannel (User.nick user) (Chan.name chan))
  in
  leave t mem ~from:me ~why:(`kick comment);
  Ok ()

let on_msg_join_0 t =
  (* "JOIN 0" actually means part from all joined channels *)
  let* me = require_registered t in
  List.iter
    (leave t ~from:me ~why:(`part None))
    (User.membership me);
  Ok ()


(* user queries *)

let user_who_flags user =
  (* Away status: the letter H ('H', 0x48) to indicate that the user is here, or
     the letter G ('G', 0x47) to indicate that the user is gone. *)
  begin match User.away user with
    | Some _ -> "G"
    | None -> "H"
  end ^
  (* Optionally, the highest channel membership prefix that the client has in <channel>,
     if the client has one. *)
  membership_prefix (User.highest_membership_priv user)

let list_who t chan users =
  let chan_str = match chan with
    | None -> "*"
    | Some chan -> Chan.name chan
  in
  List.iter
    (fun user ->
       let server = t.server_info.hostname in
       let flags = user_who_flags user in
       let { username; hostname; realname } = user.userinfo in
       reply t ("352", [chan_str; username; hostname; server;
                        User.nick user; flags; "0 " ^ realname]))
    users

let on_msg_who t mask =
  let* me = require_registered t in
  let* chan, users =
    try
      match name_type mask with
      | `nick ->
        let user = Router.find_user t.router mask in
        let chan = try Some (User.find_common_channel user me)
          with Not_found -> None in
        Ok (chan, [user])
      | `chan ->
        let chan = Router.find_chan t.router mask in
        Ok (Some chan, Chan.members chan)
      | `invalid ->
        raise Not_found
    with Not_found ->
      Ok (None, [])
  in
  list_who t chan users;
  reply t ("315", [mask; "End of WHO list"]);
  Ok ()

let list_whois t user =
  let nick = User.nick user in
  let { username; hostname; realname } = user.userinfo in
  begin
    reply t ("311", [nick; username; hostname; "*"; realname]);
    reply t ("312", [nick; t.server_info.hostname; t.server_info.hostname]);

    (* RPL_WHOISOPERATOR (313) "<client> <nick> :is an IRC operator" *)
    (* RPL_WHOISIDLE (317) "<client> <nick> <secs> <signon> :seconds idle, signon time" *)

    (* TODO: concat channel names until message becomes too long *)
    List.iter
      (fun mem ->
         let chan_str = membership_prefix mem.mem_priv ^ Chan.name mem.mem_chan in
         reply t ("319", [nick; chan_str]))
      (User.membership user);

    reply t ("320", [nick; "is a cat, meow :3"]);

    let mode = Mode.Set.{ add = User.mode user; rem = empty }in
    reply t ("379", [nick; Fmt.str "is using modes %a" Mode.Set.pp_change mode]);

    Option.iter
      (fun text ->
         reply t (away nick text))
      (User.away user);

    reply t ("318", [nick; "End of /WHOIS list"]);
  end

let on_msg_whois t nick =
  let* _me = require_registered t in
  let* user =
    try
      match name_type nick with
      | `nick -> Ok (Router.find_user t.router nick)
      | `chan | `invalid -> raise Not_found
    with Not_found ->
      Error (nosuchnick nick)
  in
  list_whois t user;
  Ok ()

let list_whowas t nick limit =
  List.iter_up_to ~limit
    (fun (nick, { username; hostname; realname }) ->
       reply t ("314", [nick; username; hostname; "*"; realname]))
    (Router.whowas t.router nick);
  reply t ("369", [nick; "End of WHOWAS"])

let on_msg_whowas t nick count =
  let* _me = require_registered t in
  let limit =
    try
      let n = Option.get (int_of_string_opt count) in
      if n <= 0 then invalid_arg "count <= 0";
      n
    with Invalid_argument _ ->
      max_int
  in
  list_whowas t nick limit;
  Ok ()

let on_msg_userhost t nicks =
  let* _me = require_registered t in
  let results =
    List.filter_map
      (fun nick ->
         try
           let user = match name_type nick with
             | `nick -> Router.find_user t.router nick
             | `chan | `invalid -> raise Not_found
           in
           let isaway = match User.away user with
             | Some _ -> '-'
             | None -> '+'
           in
           Some (Fmt.str "%s=%c%s" (User.nick user) isaway user.userinfo.hostname)
         with Not_found ->
           None)
      nicks
  in
  reply t ("302", [String.concat " " results]);
  Ok ()

let list_channels t me channels =
  begin
    reply t ("321", ["Channel"; "Users  Name"]);
    Seq.iter
      (function
        | Error err -> reply t err
        | Ok chan ->
          try
            if is_secret chan then Router.membership chan me |> ignore;
            let count = Chan.member_count chan in
            let topic = Option.value (Chan.topic chan) ~default:"" in
            reply t ("322", [Chan.name chan; string_of_int count; topic])
          with Not_found ->
            ())
      channels;
    reply t ("323", ["End of /LIST"]);
  end

let on_msg_list t names =
  let* me = require_registered t in
  let channels = match names with
    | [] ->
      Seq.map Result.ok
        (Router.all_channels_seq t.router)
    | _ ->
      Seq.map
        (fun name ->
           try
             match name_type name with
             | `chan -> Ok (Router.find_chan t.router name)
             | `nick | `invalid -> raise Not_found
           with Not_found ->
             Error (nosuchnick name))
        (List.to_seq names)
  in
  list_channels t me channels;
  Ok ()

(* welcome and quit *)

let motd t =
  let s_hostname = t.server_info.hostname in
  let s_motd = t.server_info.motd 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 on_msg_motd t =
  let* _me = require_registered t in
  motd t;
  Ok ()

let welcome t me =
  let whoami = Msg.prefix_string (User.prefix me) in
  let s_hostname = t.server_info.hostname in
  let s_version = t.server_info.version in
  let s_created = t.server_info.created in
  let s_conf = t.server_info.conf in
  let modes l = String.of_seq (List.to_seq l |> Seq.map Mode.to_char) in
  let umodes = modes s_conf.all_umodes in
  let cmodes = modes s_conf.all_cmodes in
  let pmodes = modes s_conf.all_pmodes in
  begin
    reply t ("001", [Fmt.str "Welcome to the tali IRC network %s" whoami]);
    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", s_conf.isupport @ ["are supported by this server"]);
    motd t;
  end

let on_msg_admin t =
  let* _me = require_registered t in
  reply t ("256", [t.server_info.hostname; t.server_info.admin_info]);
  Ok ()

let on_msg_info t =
  let* _me = require_registered t in
  reply t ("371", ["Running talircd version " ^ t.server_info.version]);
  reply t ("374", ["End of INFO list"]);
  Ok ()

let on_msg_help t topic =
  let* _me = require_registered t in
  let topic = Option.value topic ~default:"*" in
  Error ("524", [topic; "No help available on this topic"])

let on_msg_time t =
  let* _me = require_registered t in
  let time = Ptime_clock.now () in
  let time_unix = Fmt.str "%a" pp_unixtime time in
  let time_human = Fmt.str "%a" Server_info.pp_time time in
  reply t ("391", [t.server_info.hostname; time_unix; time_human]);
  Ok ()

let on_msg_lusers t =
  let* _me = require_registered t in
  let u = Router.lusers t.router in
  let c = Router.luserchannels t.router in
  let m = 9999 in
  reply t ("252", ["0"; "operator(s) online"]);
  reply t ("253", ["0"; "unknown connection(s)"]); (* TODO: unknown connections *)
  reply t ("254", [string_of_int c; Fmt.str "channels formed"]);
  reply t ("255", [Fmt.str "I have %d clients and %d servers" u 0]);
  reply t ("265", [string_of_int u; string_of_int m;
                   Fmt.str "Current local users %d, max %d" u m]);
  reply t ("266", [string_of_int u; string_of_int m;
                   Fmt.str "Current global users %d, max %d" u m]);
  Ok ()

let on_msg_links t =
  let* _me = require_registered t in
  reply t ("365", ["End of /LINKS list"]);
  Ok ()

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

    List.iter
      (leave t ~from:me ~why:`quit)
      (User.membership me);

    User.unregister me ~router:t.router;
    t.user <- None
  end

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

let on_msg_quit t reason =
  let reason = match reason with
    | None -> "Quit"
    | Some x -> "Quit: " ^ x
  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:t.server_info.conf.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 = 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 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


(* ping *)

let on_msg_ping t token =
  let* _me = require_registered t in
  match token with
  | None -> Ok ()
  | Some token ->
    let prefix = Server_info.prefix t.server_info in
    Outbox.send t.outbox
      (Msg.make ~prefix "PONG" [t.server_info.hostname; token]
         ~always_trailing:true);
    Ok ()

let on_msg_pong t token =
  let* _me = require_registered t in
  match t.activity with
  | Active | Inactive ->
    trace (fun m -> m "%a:@ ignored pong" pp_sockaddr t.addr);
    Ok ()
  | Pinged token' ->
    if token <> Some token' then
      debug (fun m -> m "%a:@ got weird PONG token" pp_sockaddr t.addr);
    Ok ()

let on_ping t =
  match t.activity with
  | _ when Outbox.is_closed t.outbox ->
    trace (fun m -> m "%a:@ connection stale" pp_sockaddr t.addr);
    Error ()

  | Active ->
    trace (fun m -> m "%a:@ inactive" pp_sockaddr t.addr);
    t.activity <- Inactive;
    Ok ()

  | Inactive ->
    let token = "meow" in
    trace (fun m -> m "%a:@ ping %S" pp_sockaddr t.addr token);
    t.activity <- Pinged token;
    if Option.is_some t.user then
      begin
        let prefix = Server_info.prefix t.server_info in
        Outbox.send t.outbox
          (Msg.make ~prefix "PING" [token]
             ~always_trailing:true);
      end;
    Ok ()

  | Pinged _ ->
    debug (fun m -> m "%a:@ timed out" pp_sockaddr t.addr);
    Error ()


(* message parsing *)

let concat_args = function
  | [] | [""] -> None
  | xs -> Some (String.concat " " xs)

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 (concat_args reason)
  | "MOTD", _ -> on_msg_motd t
  | "ADMIN", _ -> on_msg_admin t
  | "INFO", _ -> on_msg_info t
  | "TIME", _ -> on_msg_time t
  | "LUSERS", _ -> on_msg_lusers t
  | "LINKS", _ -> on_msg_links t
  | "HELP", args -> on_msg_help t (concat_args args)
  | "PING", args -> on_msg_ping t (concat_args args)
  | "PONG", args -> on_msg_pong t (concat_args args)
  | "JOIN", tgt :: _ when tgt <> "" -> on_msg_join t tgt
  | "JOIN 0", _ -> (* hack; see split_command_params *) on_msg_join_0 t
  | "NAMES", tgt :: _ when tgt <> "" -> on_msg_names t tgt
  | "TOPIC", tgt :: args when tgt <> "" -> on_msg_topic t tgt args
  | "PART", tgt :: reason when tgt <> "" -> on_msg_part t tgt (concat_args reason)
  | "KICK", chn :: tgt :: comment when chn <> "" && tgt <> "" ->
    on_msg_kick t chn tgt (concat_args comment)
  | "AWAY", args -> on_msg_away t (concat_args args)
  | "MODE", tgt :: args when tgt <> "" -> on_msg_mode t tgt args
  | "WHO", mask :: _ when mask <> "" -> on_msg_who t mask
  | "WHOIS", ([] | [""] | _ :: "" :: _) -> Error nonicknamegiven
  | "WHOIS", ([nick] | _ :: nick :: _) -> on_msg_whois t nick
  | "WHOWAS", ([] | "" :: _) -> Error nonicknamegiven
  | "WHOWAS", [nick] -> on_msg_whowas t nick ""
  | "WHOWAS", nick :: count :: _ -> on_msg_whowas t nick count
  | "LIST", chans :: _ -> on_msg_list t (String.split_on_char ',' chans)
  | "LIST", [] -> on_msg_list t []
  | "USERHOST", nicks -> on_msg_userhost t nicks
  | ("USER" | "JOIN" | "NAMES" | "PART" | "KICK" | "MODE" | "WHO") as cmd, _ ->
    Error (needmoreparams cmd)
  | ("CONNECT" | "KILL" | "REHASH" | "RESTART" | "STATS" | "SQUIT" | "WALLOPS"), _ ->
    Error noprivileges

  | ("PRIVMSG" | "NOTICE") as cmd, args ->
    begin match args with
      | [] | "" :: _ -> Error (norecipient cmd)
      | [_] | _ :: "" :: _ -> Error notexttosend
      | tgt :: msg :: _ -> on_msg_privmsg t tgt msg ~cmd
    end

  | cmd, _ ->
    Error (unknowncommand cmd)

let split_command_params cmd params =
  match cmd, params with
  | "JOIN", "0" :: _ ->
    ["JOIN 0", []]

  | "JOIN", tgts :: rest
    when String.contains tgts ',' ->
    (* TODO: split <keys> argument as well *)
    String.split_on_char ',' tgts |>
    List.map (fun tgt -> "JOIN", tgt :: rest)

  | ("PRIVMSG" | "NOTICE" | "NAMES" | "PART"), tgts :: rest
    when String.contains tgts ',' ->
    String.split_on_char ',' tgts |>
    List.map (fun tgt -> cmd, tgt :: rest)

  | "KICK", chan :: tgts :: rest
    when String.contains tgts ',' ->
    String.split_on_char ',' tgts |>
    List.map (fun tgt -> "KICK", chan :: 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 : Msg.t) : unit =
  let results =
    List.map
      (fun cmd ->
         trace (fun m -> m "%a@ ->@ %a" pp_sockaddr t.addr pp_args cmd);
         dispatch t cmd)
      (split_command_params
         msg.command
         msg.params)
  in
  List.iter (reply t)
    (List.flat_map list_of_errors results);
  t.activity <- Active