add part; part on quit; broadcast messages

lib/server/connection.ml

@@ -21,8 +21,15 @@ let make ~(router : Router.t) ~(addr : sockaddr) : t =
 
 let outbox t = t.outbox
 
-let shutdown t =
+let shutdown ?reason t =
-  User.quit t.user ~router:t.router;
+  if User.is_registered t.user then begin
+    (* TODO: relay to everyone interested *)
+    let reason = Option.value reason ~default:"Goot bye" in
+    Router.relay (Irc.Msg.make "QUIT" [reason])
+      ~from:t.user (`to_interested t.user);
+    User.part_all t.user;
+    User.unregister t.user ~router:t.router;
+  end;
   Outbox.close t.outbox
 
 (* message handling *)
@@ -53,11 +60,13 @@ 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 ~router:t.router with
+    let success_callback () =
+      let msg = Irc.Msg.make "NICK" [nick] in
+      Router.relay msg ~from:t.user (`to_interested t.user);
+    in
+    match User.set_nick t.user nick ~router:t.router ~success_callback with
     | `nick_in_use -> `nicknameinuse nick
-    | `nick_set ->
+    | `nick_set -> `ok
-      ((* TODO: relay NICK message *));
-      `ok
   else begin
     t.pending_nick <- Some nick;
     attempt_to_register t
@@ -77,7 +86,7 @@ let on_msg_user t username modestr realname =
 (* > messages and channels *)
 
 let on_msg_privmsg t tgt txt _ =
-  let msg = Irc.Msg.make "PRIVMSG" [tgt; txt] in
+  let msg = Irc.Msg.make "PRIVMSG" [tgt; txt] ~always_trailing:true in
   let dst =
     try
       match Irc.name_type tgt with
@@ -89,6 +98,7 @@ let on_msg_privmsg t tgt txt _ =
   match dst with
   | `not_found -> `nosuchnick tgt
   | (`to_user _ | `to_chan _) as dst ->
+    (* TODO: check if allowed to send to channel *)
     Router.relay msg ~from:t.user dst;
     `ok
 
@@ -100,6 +110,19 @@ let list_names chan =
   in
   `names ("@", Chan.name chan, names)
 
+let on_msg_names t name _ =
+  match Irc.name_type name with
+  | `nick | `invalid ->
+    if name = "" then `needmoreparams else `nosuchchannel name
+  | `chan ->
+    let chan = try Some (Router.find_chan t.router name)
+      with Not_found -> None
+    in
+    (* TODO: check if allowed to list names *)
+    match chan with
+    | None -> `nosuchchannel name
+    | Some chan -> list_names chan
+
 let on_msg_join t name _ =
   match Irc.name_type name with
   | `nick | `invalid ->
@@ -113,15 +136,17 @@ let on_msg_join t name _ =
         Chan.register chan ~router:t.router;
         chan
     in
-    if not (Chan.is_member chan t.user) then begin
+    if Chan.is_member chan t.user then
+      `ok
+    else begin
       Chan.join chan t.user;
-      let join_msg = Irc.Msg.make "JOIN" [name] in
+      let msg = Irc.Msg.make "JOIN" [name] in
-      Router.relay join_msg ~from:t.user `to_self;
+      Router.relay msg ~from:t.user `to_self;
-      Router.relay join_msg ~from:t.user (`to_chan chan);
+      Router.relay msg ~from:t.user (`to_chan chan);
-    end;
+      list_names chan
-    list_names chan
+    end
 
-let on_msg_names t name _ =
+let on_msg_part t name _ =
   match Irc.name_type name with
   | `nick | `invalid ->
     if name = "" then `needmoreparams else `nosuchchannel name
@@ -129,20 +154,32 @@ let on_msg_names t name _ =
     let chan = try Some (Router.find_chan t.router name)
       with Not_found -> None
     in
+    (* TODO: check if allowed to list names *)
     match chan with
     | None -> `nosuchchannel name
-    | Some chan -> list_names chan
+    | Some chan ->
+      if not (Chan.is_member chan t.user) then `notonchannel name
+      else begin
+        let msg = Irc.Msg.make "PART" [name] in
+        Router.relay msg ~from:t.user `to_self;
+        Router.relay msg ~from:t.user (`to_chan chan);
+        Chan.part chan t.user;
+        if Chan.no_members chan then
+          Chan.unregister chan ~router:t.router;
+        `ok
+      end
 
 let on_msg_privmsg t tgt msg = require_registered t (on_msg_privmsg t tgt msg)
-let on_msg_join t name = require_registered t (on_msg_join t name)
 let on_msg_names t name = require_registered t (on_msg_names t name)
+let on_msg_join t name = require_registered t (on_msg_join t name)
+let on_msg_part t name = require_registered t (on_msg_part t name)
     
 (* > misc *)
 
-let on_msg_quit t why =
+let on_msg_quit t reason =
-  let why = String.concat " " why in
+  let reason = String.concat " " reason in
-  Logs.debug (fun m -> m "%a: quit: %S" pp_sockaddr t.addr why);
+  shutdown t ~reason;
-  `quit
+  `ok
 
 (* message sending *)
 
@@ -199,6 +236,7 @@ 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_notonchannel t chan = rpl t "442" [chan; "You're not on that channel"]
 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)"]
@@ -221,23 +259,25 @@ let on_msg t (msg : Irc.Msg.t) : unit =
     | "JOIN", _ -> `needmoreparams
     | "NAMES", tgt :: _ -> on_msg_names t tgt
     | "NAMES", _ -> `needmoreparams
+    | "PART", tgt :: _ -> on_msg_part t tgt
+    | "PART", _ -> `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
+  | `erroneusnickname n -> err_erroneousnickname t n
   | `needmoreparams -> err_needmoreparams t msg.command
   | `nicknameinuse n -> err_nicknameinuse t n    
+  | `nonicknamegiven -> err_nonicknamegiven t
   | `norecipient -> err_norecipient t msg.command
-  | `nosuchnick n -> err_nosuchnick t n
   | `nosuchchannel c -> err_nosuchchannel t c
+  | `nosuchnick n -> err_nosuchnick t n
   | `notexttosend -> err_notexttosend t
+  | `notonchannel c -> err_notonchannel t c
   | `notregistered -> err_notregistered t
   | `unknowncommand -> err_unknowncommand t msg.command
-  | `nonicknamegiven -> err_nonicknamegiven t
-  | `erroneusnickname n -> err_erroneousnickname t n

lib/server/router.ml

@@ -25,8 +25,8 @@ and chan = {
 and membership = {
   mem_user : user;
   mem_chan : chan;
-  mutable mem_of_chan : membership Dllist.node option;
+  mutable mem_in_chan : membership Dllist.node option;
-  mutable mem_of_user : membership Dllist.node option;
+  (* mutable mem_of_user : membership Dllist.node option; *)
 }
 
 type router = t
@@ -56,6 +56,15 @@ let relay ~from msg target =
     Dllist.iter_l (fun m -> Outbox.incl bcc m.mem_user.outbox) dst.members;
     Outbox.excl from.outbox;
     Outbox.send_all bcc msg
+  | `to_interested user ->
+    let bcc = Outbox.make_bcc () in
+    Dllist.iter_l
+      (fun m ->
+         Dllist.iter_l
+           (fun m -> Outbox.incl bcc m.mem_user.outbox)
+           m.mem_chan.members)
+      user.membership;
+    Outbox.send_all bcc msg
 
 module User = struct
   type t = user
@@ -80,11 +89,13 @@ module User = struct
     Hashtbl.remove router.users t.nick_key;
     t.nick_key <- empty_string_ci
 
-  let set_nick t new_nick ~router =
+  let set_nick ?(success_callback = ignore) t new_nick ~router =
     let key = string_ci new_nick in
     if Hashtbl.mem router.users key then
       `nick_in_use
     else begin
+      (* hack to allow broadcasting a NICK message before nick is actually changed *)
+      success_callback ();
       unregister t ~router;
       Hashtbl.add router.users key t;
       t.nick <- new_nick;
@@ -92,13 +103,13 @@ module User = struct
       `nick_set
     end
 
-  let quit t ~router =
+  let rec part_all t =
-    if is_registered t then begin
+    match Dllist.take_l t.membership with
-      let reason = "Goot bye" in
+    | m ->
-      (* TODO: relay to everyone interested *)
+      Option.iter Dllist.remove m.mem_in_chan;
-      relay ~from:t (Irc.Msg.make "QUIT" [reason]) `to_self;
+      part_all t
-      unregister t ~router
+    | exception Dllist.Empty ->
-    end
+      ()
 end
 
 module Chan = struct
@@ -114,6 +125,7 @@ module Chan = struct
 
   let name t = t.name
   let topic t = t.topic
+  let no_members t = Dllist.is_empty t.members
 
   let register t ~router =
     Hashtbl.replace router.channels t.name_key t
@@ -125,18 +137,27 @@ module Chan = struct
     Dllist.fold_r (fun m xs -> m.mem_user :: xs) t.members []
 
   let is_member t user =
-    let is_mem m = m.mem_user == user in
+    let is_mem m = m.mem_chan == t in
-    Option.is_some (Dllist.find_node_opt_l is_mem t.members)
+    try
+      ignore (Dllist.find_node_l is_mem user.membership);
+      true
+    with Not_found ->
+      false
 
   let join t user =
     let m = {
       mem_chan = t;
       mem_user = user;
-      mem_of_chan = None;
+      mem_in_chan = None;
-      mem_of_user = None;
     } in
     begin
-      m.mem_of_chan <- Some (Dllist.add_r m t.members);
+      m.mem_in_chan <- Some (Dllist.add_r m t.members);
-      m.mem_of_user <- Some (Dllist.add_r m user.membership);
+      ignore (Dllist.add_r m user.membership);
     end
+
+  let part t user =
+    let is_mem m = m.mem_chan == t in
+    let mem = Dllist.find_node_l is_mem user.membership in
+    Option.iter Dllist.remove (Dllist.get mem).mem_in_chan;
+    Dllist.remove mem
 end