iitalics
/
talircd
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

preliminary channels impl

This commit is contained in:
tali 2024-01-09 21:20:16 -05:00
parent 7fb44540d9
commit 17e3739cfe
4 changed files with 185 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
lib/server/connection.ml
View File

@ -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

2
lib/server/dune
View File

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

4
lib/server/import.ml
View File

@ -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

142
lib/server/router.ml
View File

@ -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