refactor Router.relay to allow sending to multiple targets at once

lib/server/connection.ml

@@ -24,7 +24,7 @@ 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);
+       Router.relay (Irc.Msg.make "QUIT" [reason]) ~from:me [`to_interested];
        User.part_all me;
        (* TODO: BUG: unregister empty channels *)
        User.unregister me ~router:t.router)
@@ -109,7 +109,7 @@ let on_msg_nick ~welcome t nick =
       match
         User.set_nick me nick
           ~router:t.router
-          ~success_callback:(fun () -> Router.relay msg ~from:me (`to_interested me))
+          ~success_callback:(fun () -> Router.relay msg ~from:me [`to_interested])
       with
       | `nick_in_use -> Error (nicknameinuse nick)
       | `nick_set -> Ok ()
@@ -133,21 +133,26 @@ let on_msg_user ~welcome t username realname =
 
 (* messages and channels *)
 
-let on_msg_privmsg t tgt txt =
+let on_msg_privmsg t name txt =
   let* me = require_registered t in
-  let* dst =
+  let* tgt =
     try
-      match Irc.name_type tgt with
+      match Irc.name_type name with
-      | `chan -> Ok (`to_chan (Router.find_chan t.router tgt))
+      | `chan -> Ok (`chan (Router.find_chan t.router name))
-      | _     -> Ok (`to_user (Router.find_user t.router tgt))
+      | _     -> Ok (`user (Router.find_user t.router name))
     with Not_found ->
-      Error (nosuchnick tgt)
+      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 msg = Irc.Msg.make "PRIVMSG" [tgt; txt] ~always_trailing:true in
+  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 ()
 
@@ -194,8 +199,7 @@ let on_msg_join t name =
   (* 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; `to_self];
-  Router.relay msg ~from:me (`to_chan chan);
   (* TODO: send channel topic *)
   list_names t chan;
   Ok ()
@@ -213,8 +217,7 @@ let on_msg_part t 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; `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);
@@ -228,7 +231,7 @@ let on_msg_part t name =
 let user_get_mode user me =
   let modestr = Fmt.str "+%a" Irc.Mode.Set.pp (User.mode user) in
   let msg = Irc.Msg.make "MODE" [User.nick user; modestr] ~always_trailing:true in
-  Router.relay msg ~from:me `to_self;
+  Router.relay msg ~from:me [`to_self];
   Ok ()
 
 let user_set_mode user me modestr _args =
@@ -248,8 +251,7 @@ let user_set_mode user me modestr _args =
     mode, Fmt.str "%a" Irc.Mode.Parse.pp_user_mode_set { add; rem }
   in
   let msg = Irc.Msg.make "MODE" [User.nick user; modestr] ~always_trailing:true in
-  (* TODO: if setting mode for user besides self, notify them too *)
+  Router.relay msg ~from:me [`to_user user; `to_self];
-  Router.relay msg ~from:me `to_self;
   User.set_mode user mode;
   Ok ()
 

lib/server/outbox.ml

@@ -5,30 +5,35 @@ open! Import
 type t = {
   stream : Irc.Msg.t Lwt_stream.t;
   push : Irc.Msg.t option -> unit;
-  mutable bcc : t Dllist.node option;
+  mutable bcc_incl : bool;
 }
 
 let make () =
   let stream, push = Lwt_stream.create () in
-  { stream; push; bcc = None }
+  { stream; push; bcc_incl = false }
 
 let stream t = t.stream
 let send t msg = try t.push (Some msg) with Lwt_stream.Closed -> ()
 let close t = try t.push None with Lwt_stream.Closed -> ()
 
 module Bcc = struct
+  (** this module is used to send a message to a number of outboxes at once without sending
+      to the same destination twice. it uses a global linked list of recipients with an
+      intrusive bool ([outbox.bcc_incl]) to prevent enqueuing the same destination twice.
+
+      [Bcc.add a; Bcc.add b; Bcc.send_all msg;
+      (* sends [msg] to [a] and [b]. *)]
+  *)
+
   let _recipients = Dllist.create ()
 
-  let incl obx =
+  let add obx =
-    Option.iter Dllist.remove obx.bcc;
+    if not obx.bcc_incl then
-    obx.bcc <- Some (Dllist.add_r obx _recipients)
+      let _ = Dllist.add_r obx _recipients in
-
+      obx.bcc_incl <- true
-  let excl obx =
-    Option.iter Dllist.remove obx.bcc;
-    obx.bcc <- None
 
   let rec send_all msg =
     match Dllist.take_l _recipients with
-    | obx -> obx.bcc <- None; send obx msg; send_all msg
+    | obx -> obx.bcc_incl <- false; send obx msg; send_all msg
     | exception Dllist.Empty -> ()
 end

lib/server/router.ml

@@ -43,25 +43,32 @@ let find_chan t name =
 let user_prefix user =
   Irc.Msg.User_prefix (user.nick, Some user.userinfo)  
 
-let relay ~(from : user) (msg : Irc.Msg.t) target =
+let chan_members chan =
-  let msg = { msg with prefix = user_prefix from } in
+  Dllist.fold_r (fun m xs -> m.mem_user :: xs) chan.members []
-  match target with
+
-  | `to_self ->
+let user_channels user =
-    Outbox.send from.outbox msg
+  Dllist.fold_r (fun m xs -> m.mem_chan :: xs) user.membership []
-  | `to_user dst ->
+
-    Outbox.send dst.outbox msg
+let relay ~(from : user) (msg : Irc.Msg.t) tgts =
-  | `to_chan dst ->
+  let msg =
-    Dllist.iter_l (fun m -> Outbox.Bcc.incl m.mem_user.outbox) dst.members;
+    if msg.prefix = No_prefix then
-    Outbox.Bcc.excl from.outbox;
+      { msg with prefix = user_prefix from }
-    Outbox.Bcc.send_all msg
+    else msg
-  | `to_interested user ->
+  in
-    Dllist.iter_l
+  let bcc u = Outbox.Bcc.add u.outbox in
-      (fun m ->
+  let bcc_not_self u = if u != from then bcc u in
-         Dllist.iter_l
+  let bcc_channel c = List.iter bcc_not_self (chan_members c) in
-           (fun m -> Outbox.Bcc.incl m.mem_user.outbox)
+  List.iter
-           m.mem_chan.members)
+    (function
-      user.membership;
+      | `to_self -> bcc from
-    Outbox.Bcc.send_all msg
+      | `to_user tgt -> bcc tgt
+      | `to_chan tgt -> bcc_channel tgt
+      | `to_interested -> bcc from; List.iter bcc_channel (user_channels from))
+    tgts;
+  Outbox.Bcc.send_all msg
+
+(* TODO: split out [User] and [Chan] into separate files *)
+
 
 module User = struct
   type t = user
@@ -79,6 +86,7 @@ module User = struct
   let outbox t = t.outbox
   let nick t = t.nick
   let mode t = t.mode
+  let channels = user_channels
   let prefix = user_prefix
   (* let is_registered t = t.nick_key <> empty_string_ci *)
 
@@ -104,6 +112,7 @@ module User = struct
     t.mode <- new_mode
 
   let rec part_all t =
+    (* List.iter (fun c -> Chan.part c t) (channels t) *)
     match Dllist.take_l t.membership with
     | m ->
       Option.iter Dllist.remove m.mem_in_chan;
@@ -112,6 +121,7 @@ module User = struct
       ()
 end
 
+
 module Chan = struct
   type t = chan
 
@@ -125,6 +135,7 @@ module Chan = struct
 
   let name t = t.name
   let topic t = t.topic
+  let members = chan_members
   let no_members t = Dllist.is_empty t.members
 
   let register t ~router =
@@ -133,9 +144,6 @@ module Chan = struct
   let unregister t ~router =
     Hashtbl.remove router.channels t.name_key
 
-  let members t =
-    Dllist.fold_r (fun m xs -> m.mem_user :: xs) t.members []
-
   let is_member t user =
     let is_mem m = m.mem_chan == t in
     try