diff --git a/lib/server/connection.ml b/lib/server/connection.ml index a3dcc0f..7e72bdf 100644 --- a/lib/server/connection.ml +++ b/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 - { addr; user; outbox; pending_nick = None } + let user = User.make ~hostname ~outbox in + { 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 () = - Outbox.send t.outbox - (Irc.Msg.make "MODE" [nick; Fmt.str "+%a" Irc.Mode.pp t.user.mode] - ~prefix:(User.prefix t.user)); - in - Lwt.on_success (Lwt.pause ()) send_mode; + let mode_str = Fmt.str "+%a" Irc.Mode.pp t.user.mode in + let mode_msg = Irc.Msg.make "MODE" [nick; mode_str] in + defer (fun () -> Router.relay mode_msg ~from:t.user `to_self); `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 _ = - match Router.find_user t.user.router tgt with - | None -> `nosuchnick tgt - | Some dst -> Router.privmsg t.user (`user dst) msg; `ok +let on_msg_privmsg t tgt txt _ = + let msg = Irc.Msg.make "PRIVMSG" [tgt; txt] in + let dst = + 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 _ = - Outbox.send t.outbox - (Irc.Msg.make "JOIN" [tgt] ~prefix:(User.prefix t.user)); - `names ("@", tgt, ["@", User.nick t.user; "", "moe"; "", "barry"]) +let list_names chan = + let names = + List.map + (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 :: _ -> - on_msg_nick t new_nick + | "NICK", new_nick :: _ -> on_msg_nick t new_nick | "NICK", [] -> `nonicknamegiven - | "USER", username :: modestr :: _host :: realname :: _ -> - on_msg_user t username modestr realname - | "QUIT", why -> - on_msg_quit t why + | "USER", u :: m :: _h :: r :: _ -> on_msg_user t u m r + | "USER", _ -> `needmoreparams + | "QUIT", why -> on_msg_quit t why | "MOTD", _ -> `motd - | "PRIVMSG", tgt :: msg :: _ -> - on_msg_privmsg t tgt msg + | "PRIVMSG", tgt :: msg :: _ -> on_msg_privmsg t tgt msg | "PRIVMSG", [_] -> `notexttosend | "PRIVMSG", [] -> `norecipient - | "JOIN", tgt :: _ -> - on_msg_join t tgt - | "USER", _ | "JOIN", _ -> `needmoreparams + | "JOIN", tgt :: _ -> on_msg_join t tgt + | "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 diff --git a/lib/server/dune b/lib/server/dune index 84ae141..c7a24eb 100644 --- a/lib/server/dune +++ b/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)) diff --git a/lib/server/import.ml b/lib/server/import.ml index 5e4159e..9dada26 100644 --- a/lib/server/import.ml +++ b/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 diff --git a/lib/server/router.ml b/lib/server/router.ml index 8cad975..361c478 100644 --- a/lib/server/router.ml +++ b/lib/server/router.ml @@ -1,82 +1,142 @@ open! Import type t = { - users : (string_ci, user) Hashtbl.t - (* TODO: channels *) + users : (string_ci, user) Hashtbl.t; + 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 is_registered t = t.key <> empty_string_ci + let prefix = user_prefix + let is_registered t = t.nick_key <> empty_string_ci - let unregister t = - Hashtbl.remove t.router.users t.key; - t.key <- empty_string_ci + let unregister t ~router = + Hashtbl.remove router.users t.nick_key; + 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 *)); - if is_registered t then - 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; + unregister t ~router; + Hashtbl.add router.users key t; 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 *) - Outbox.send t.outbox - (Irc.Msg.make "QUIT" ["Closed"] - ~prefix:(prefix t) - ~always_trailing:true); - (* TODO: relay QUIT message *) - unregister t + let reason = "Goot bye" in + (* TODO: relay to everyone interested *) + relay ~from:t (Irc.Msg.make "QUIT" [reason]) `to_self; + unregister t ~router end end -let privmsg src dst txt = - let prefix = User.prefix src in - match dst with - | `user dst -> - let msg = Irc.Msg.make "PRIVMSG" [User.nick dst; txt] ~prefix in - Outbox.send (User.outbox dst) msg +module Chan = struct + type t = chan + + let make ~name = + { + 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