diff --git a/lib/server/connection.ml b/lib/server/connection.ml index 9e2150e..c2fb85f 100644 --- a/lib/server/connection.ml +++ b/lib/server/connection.ml @@ -35,6 +35,8 @@ type reply = string * string list type 'a result = ('a, reply) Result.t +let ( >>= ) = Result.bind + let list_of_errors = function | Ok () -> [] | Error e -> [e] @@ -433,18 +435,23 @@ let on_msg_join t name = Ok () end -let leave t user chan ~why = - let mem = Router.membership chan user in +let leave t (mem : membership) ~from ~why = + let user = mem.mem_user in + let chan = mem.mem_chan in begin match why with - (* TODO: KICK *) | `quit -> - (* if called from [quit], then we already relayed the QUIT message *) + (* assume QUIT message has already been relayed *) () | `part reason -> let always_trailing = Option.is_some reason in - let reason = Option.to_list reason in - let msg = Msg.make "PART" (Chan.name chan :: reason) ~always_trailing in - Router.relay msg ~from:user [`to_chan chan; `to_self] + 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 @@ -454,10 +461,6 @@ let leave t user chan ~why = 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 @@ -467,18 +470,43 @@ let on_msg_part t name reason = with Not_found -> Error (nosuchchannel name) in - try - leave t me chan ~why:(`part reason); - Ok () - with Not_found -> - Error (notonchannel name) + 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 me ~why:(`part None)) - (User.channels me); + (leave t ~from:me ~why:(`part None)) + (User.membership me); Ok () @@ -523,8 +551,8 @@ let quit t me ~reason = Router.relay msg ~from:me [`to_interested]; List.iter - (leave t me ~why:`quit) - (User.channels me); + (leave t ~from:me ~why:`quit) + (User.membership me); User.unregister me ~router:t.router; t.user <- None @@ -536,8 +564,8 @@ let close ?(reason = "Client closed") t = let on_msg_quit t reason = let reason = match reason with - | [] -> "Quit" - | xs -> String.concat " " ("Quit:" :: xs) + | None -> "Quit" + | Some x -> "Quit: " ^ x in close t ~reason; Ok () @@ -602,11 +630,15 @@ let on_msg_user t username realname = (* 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 reason + | "QUIT", reason -> on_msg_quit t (concat_args reason) | "MOTD", _ -> on_msg_motd t | "PRIVMSG", ([] | "" :: _) -> Error norecipient | "PRIVMSG", ([_] | _ :: "" :: _) -> Error notexttosend @@ -615,9 +647,11 @@ let dispatch t = function | "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 reason + | "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) | "MODE", tgt :: args when tgt <> "" -> on_msg_mode t tgt args - | ("USER" | "JOIN" | "NAMES" | "PART" | "MODE") as cmd, _ -> + | ("USER" | "JOIN" | "NAMES" | "PART" | "KICK" | "MODE") as cmd, _ -> Error (needmoreparams cmd) | cmd, _ -> Error (unknowncommand cmd) @@ -638,6 +672,12 @@ let split_command_params cmd params = (* TODO: "JOIN" should be handled specially *) 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] diff --git a/lib/server/user.ml b/lib/server/user.ml index 32d327d..42f4ee8 100644 --- a/lib/server/user.ml +++ b/lib/server/user.ml @@ -31,5 +31,8 @@ let is_registered t ~router = Hashtbl.mem router.users t.nick_key let prefix t = Irc.Msg.User_prefix (t.nick, Some t.userinfo) +let membership t = + Dllist.fold_r (fun m xs -> m :: xs) t.membership [] + let channels t = Dllist.fold_r (fun m xs -> m.mem_chan :: xs) t.membership []