preliminary channels impl

lib/server/connection.ml

@@ -1,8 +1,10 @@
 open! Import
 module User = Router.User
+module Chan = Router.Chan
 
 type t = {
   addr : sockaddr;
+  router : Router.t;
   user : User.t;
   outbox : Outbox.t;
   mutable pending_nick : string option;
@@ -14,13 +16,13 @@ let make ~(router : Router.t) ~(addr : sockaddr) : t =
     | ADDR_UNIX path -> path
   in
   let outbox = Outbox.make () in
-  let user = User.make ~router ~hostname ~outbox in
+  let user = User.make ~hostname ~outbox in
-  { addr; user; outbox; pending_nick = None }
+  { addr; router; user; outbox; pending_nick = None }
 
 let outbox t = t.outbox
 
 let shutdown t =
-  User.quit t.user;
+  User.quit t.user ~router:t.router;
   Outbox.close t.outbox
 
 (* message handling *)
@@ -37,15 +39,12 @@ let attempt_to_register t =
   match t.pending_nick, t.user.userinfo with
   | Some nick, Some _userinfo ->
     t.pending_nick <- None;
-    begin match User.set_nick t.user nick with
+    begin match User.set_nick t.user nick ~router:t.router with
       | `nick_in_use -> `nicknameinuse nick
       | `nick_set ->
-        let send_mode () =
+        let mode_str = Fmt.str "+%a" Irc.Mode.pp t.user.mode in
-          Outbox.send t.outbox
+        let mode_msg = Irc.Msg.make "MODE" [nick; mode_str] in
-            (Irc.Msg.make "MODE" [nick; Fmt.str "+%a" Irc.Mode.pp t.user.mode]
+        defer (fun () -> Router.relay mode_msg ~from:t.user `to_self);
-               ~prefix:(User.prefix t.user));
-        in
-        Lwt.on_success (Lwt.pause ()) send_mode;
         `welcome
     end
   | _, _ -> `ok
@@ -54,7 +53,7 @@ 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 with
+    match User.set_nick t.user nick ~router:t.router with
     | `nick_in_use -> `nicknameinuse nick
     | `nick_set ->
       ((* TODO: relay NICK message *));
@@ -77,18 +76,66 @@ let on_msg_user t username modestr realname =
 
 (* > messages and channels *)
 
-let on_msg_privmsg t tgt msg _ =
+let on_msg_privmsg t tgt txt _ =
-  match Router.find_user t.user.router tgt with
+  let msg = Irc.Msg.make "PRIVMSG" [tgt; txt] in
-  | None -> `nosuchnick tgt
+  let dst =
-  | Some dst -> Router.privmsg t.user (`user dst) msg; `ok
+    try
+      match Irc.name_type tgt with
+      | `chan -> `to_chan (Router.find_chan t.router tgt)
+      | `nick -> `to_user (Router.find_user t.router tgt)
+      | `invalid -> `not_found
+    with Not_found -> `not_found
+  in
+  match dst with
+  | `not_found -> `nosuchnick tgt
+  | (`to_user _ | `to_chan _) as dst ->
+    Router.relay msg ~from:t.user dst;
+    `ok
 
-let on_msg_join t tgt _ =
+let list_names chan =
-  Outbox.send t.outbox
+  let names =
-    (Irc.Msg.make "JOIN" [tgt] ~prefix:(User.prefix t.user));
+    List.map
-  `names ("@", tgt, ["@", User.nick t.user; "", "moe"; "", "barry"])
+      (fun u -> "", User.nick u)
+      (Chan.members chan)
+  in
+  `names ("@", Chan.name chan, names)
+
+let on_msg_join t name _ =
+  match Irc.name_type name with
+  | `nick | `invalid ->
+    if name = "" then `needmoreparams else `nosuchchannel name
+  | `chan ->
+    let chan = try Router.find_chan t.router name
+      with Not_found ->
+        Logs.debug (fun m -> m "making new channel %S" name);
+        let chan = Chan.make ~name in
+        (* TODO: op user after joining *)
+        Chan.register chan ~router:t.router;
+        chan
+    in
+    if not (Chan.is_member chan t.user) then begin
+      Chan.join chan t.user;
+      let join_msg = Irc.Msg.make "JOIN" [name] in
+      Router.relay join_msg ~from:t.user `to_self;
+      Router.relay join_msg ~from:t.user (`to_chan chan);
+    end;
+    list_names chan
+
+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
+    match chan with
+    | None -> `nosuchchannel name
+    | Some chan -> list_names chan
 
 let on_msg_privmsg t tgt msg = require_registered t (on_msg_privmsg t tgt msg)
-let on_msg_join t tgt = require_registered t (on_msg_join t tgt)
+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)
     
 (* > misc *)
 
@@ -145,6 +192,7 @@ let rpl_names t chan_prefix chan users =
   end
 
 let err_nosuchnick t tgt = rpl t "401" [tgt; "No such nick/channel"]
+let err_nosuchchannel t tgt = rpl t "403" [tgt; "No such channel"]
 let err_norecipient t cmd = rpl t "411" [Fmt.str "No recipient given (%s)" cmd]
 let err_notexttosend t = rpl t "412" ["No text to send"]
 let err_unknowncommand t cmd = rpl t "421" [cmd; "Unknown command"]
@@ -158,23 +206,21 @@ let err_alreadyregistered t = rpl t "462" ["Unauthorized command (already regist
 (* message parsing *)
 
 let on_msg t (msg : Irc.Msg.t) : unit =
-  Logs.debug (fun m -> m "%a: %a" pp_sockaddr t.addr Irc.Msg.pp msg);
+  (* Logs.debug (fun m -> m "%a: %a" pp_sockaddr t.addr Irc.Msg.pp msg); *)
   let result =
     match msg.command, msg.params with
-    | "NICK", new_nick :: _ ->
+    | "NICK", new_nick :: _ -> on_msg_nick t new_nick
-      on_msg_nick t new_nick
     | "NICK", [] -> `nonicknamegiven
-    | "USER", username :: modestr :: _host :: realname :: _ ->
+    | "USER", u :: m :: _h :: r :: _ -> on_msg_user t u m r
-      on_msg_user t username modestr realname
+    | "USER", _ -> `needmoreparams
-    | "QUIT", why ->
+    | "QUIT", why -> on_msg_quit t why
-      on_msg_quit t why
     | "MOTD", _ -> `motd
-    | "PRIVMSG", tgt :: msg :: _ ->
+    | "PRIVMSG", tgt :: msg :: _ -> on_msg_privmsg t tgt msg
-      on_msg_privmsg t tgt msg
     | "PRIVMSG", [_] -> `notexttosend | "PRIVMSG", [] -> `norecipient
-    | "JOIN", tgt :: _ ->
+    | "JOIN", tgt :: _ -> on_msg_join t tgt
-      on_msg_join t tgt
+    | "JOIN", _ -> `needmoreparams
-    | "USER", _ | "JOIN", _ -> `needmoreparams
+    | "NAMES", tgt :: _ -> on_msg_names t tgt
+    | "NAMES", _ -> `needmoreparams
     | _, _ -> `unknowncommand
   in
   match result with
@@ -189,6 +235,7 @@ let on_msg t (msg : Irc.Msg.t) : unit =
   | `nicknameinuse n -> err_nicknameinuse t n    
   | `norecipient -> err_norecipient t msg.command
   | `nosuchnick n -> err_nosuchnick t n
+  | `nosuchchannel c -> err_nosuchchannel t c
   | `notexttosend -> err_notexttosend t
   | `notregistered -> err_notregistered t
   | `unknowncommand -> err_unknowncommand t msg.command

lib/server/dune

@@ -2,4 +2,4 @@
  (package talircd)
  (name server)
  (libraries
-   lwt lwt.unix logs fmt irc))
+   lwt lwt.unix lwt-dllist logs fmt irc))

lib/server/import.ml

@@ -1,5 +1,6 @@
 include Lwt.Syntax
 include Lwt.Infix
+module Dllist = Lwt_dllist
 
 type sockaddr = Unix.sockaddr
 type fd = Lwt_unix.file_descr
@@ -12,3 +13,6 @@ type string_ci = Case_insensitive of string [@@unboxed]
 let pp_string_ci ppf (Case_insensitive s) = Fmt.string ppf s
 let string_ci s = Case_insensitive (String.lowercase_ascii s)
 let empty_string_ci = Case_insensitive ""
+
+let defer f =
+  Lwt.on_success (Lwt.pause ()) f

lib/server/router.ml

@@ -1,82 +1,142 @@
 open! Import
 
 type t = {
-  users : (string_ci, user) Hashtbl.t
+  users : (string_ci, user) Hashtbl.t;
-  (* TODO: channels *)
+  channels : (string_ci, chan) Hashtbl.t;
 }
 
 and user = {
-  router : t;
-  hostname : string;
   outbox : Outbox.t;
-  mutable key : string_ci;
+  hostname : string;
   mutable nick : Irc.name;
+  mutable nick_key : string_ci;
   mutable userinfo : Irc.userinfo option;
   mutable mode : Irc.Mode.t;
+  mutable membership : membership Dllist.t;
 }
 
+and chan = {
+  name : Irc.name;
+  name_key : string_ci;
+  mutable topic : string option;
+  mutable members : membership Dllist.t;
+}
+
+and membership = {
+  mem_user : user;
+  mem_chan : chan;
+  mutable mem_of_chan : membership Dllist.node option;
+  mutable mem_of_user : membership Dllist.node option;
+}
+
+type router = t
+
 let make () =
-  { users = Hashtbl.create 4096 }
+  { users = Hashtbl.create 4096;
+    channels = Hashtbl.create 4096 }
 
 let find_user t nick =
-  Hashtbl.find_opt t.users (string_ci nick)
+  Hashtbl.find t.users (string_ci nick)
+
+let find_chan t name =
+  Hashtbl.find t.channels (string_ci name)
+
+let user_prefix u =
+  Irc.Msg.User_prefix (u.nick, u.userinfo, Some u.hostname)
+
+let relay ~from msg target =
+  let msg = { msg with Irc.Msg.prefix = user_prefix from } in
+  match target with
+  | `to_self ->
+    Outbox.send from.outbox msg
+  | `to_user dst ->
+    Outbox.send dst.outbox msg
+  | `to_chan dst ->
+    let bcc = Outbox.make_bcc () in
+    Dllist.iter_l (fun m -> Outbox.incl bcc m.mem_user.outbox) dst.members;
+    Outbox.excl from.outbox;
+    Outbox.send_all bcc msg
 
 module User = struct
   type t = user
 
-  let make ~router ~hostname ~outbox =
+  let make ~hostname ~outbox =
     {
-      router;
       hostname;
-      key = empty_string_ci;
+      outbox;
       nick = "*";
+      nick_key = empty_string_ci;
       userinfo = None;
       mode = Irc.Mode.of_string "iw";
-      outbox;
+      membership = Dllist.create ();
     }
 
   let outbox t = t.outbox
   let nick t = t.nick
-  let prefix t = Irc.Msg.User_prefix (t.nick, t.userinfo, Some t.hostname)
+  let prefix = user_prefix
-  let is_registered t = t.key <> empty_string_ci
+  let is_registered t = t.nick_key <> empty_string_ci
 
-  let unregister t =
+  let unregister t ~router =
-    Hashtbl.remove t.router.users t.key;
+    Hashtbl.remove router.users t.nick_key;
-    t.key <- empty_string_ci
+    t.nick_key <- empty_string_ci
 
-  let set_nick t new_nick =
+  let set_nick t new_nick ~router =
     let key = string_ci new_nick in
-    if Hashtbl.mem t.router.users key then
+    if Hashtbl.mem router.users key then
       `nick_in_use
     else begin
-      ((* TODO: relay NICK message *));
+      unregister t ~router;
-      if is_registered t then
+      Hashtbl.add router.users key t;
-        Outbox.send t.outbox
-          (Irc.Msg.make "NICK" [new_nick]
-             ~prefix:(prefix t)
-             ~always_trailing:true);
-      unregister t;
-      Hashtbl.add t.router.users key t;
-      t.key <- key;
       t.nick <- new_nick;
+      t.nick_key <- key;
       `nick_set
     end
 
-  let quit t =
+  let quit t ~router =
     if is_registered t then begin
-      (* TODO: quit reason *)
+      let reason = "Goot bye" in
-      Outbox.send t.outbox
+      (* TODO: relay to everyone interested *)
-        (Irc.Msg.make "QUIT" ["Closed"]
+      relay ~from:t (Irc.Msg.make "QUIT" [reason]) `to_self;
-           ~prefix:(prefix t)
+      unregister t ~router
-           ~always_trailing:true);
-      (* TODO: relay QUIT message *)
-      unregister t
     end
 end
 
-let privmsg src dst txt =
+module Chan = struct
-  let prefix = User.prefix src in
+  type t = chan
-  match dst with
+
-  | `user dst ->
+  let make ~name =
-    let msg = Irc.Msg.make "PRIVMSG" [User.nick dst; txt] ~prefix in
+    {
-    Outbox.send (User.outbox dst) msg
+      name;
+      name_key = string_ci name;
+      topic = None;
+      members = Dllist.create ();
+    }
+
+  let name t = t.name
+  let topic t = t.topic
+
+  let register t ~router =
+    Hashtbl.replace router.channels t.name_key t
+
+  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_user == user in
+    Option.is_some (Dllist.find_node_opt_l is_mem t.members)
+
+  let join t user =
+    let m = {
+      mem_chan = t;
+      mem_user = user;
+      mem_of_chan = None;
+      mem_of_user = None;
+    } in
+    begin
+      m.mem_of_chan <- Some (Dllist.add_r m t.members);
+      m.mem_of_user <- Some (Dllist.add_r m user.membership);
+    end
+end