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

big huge refactor of channel join/part logic

This commit is contained in:
tali 2024-01-23 13:13:41 -05:00
parent 0cabfe5dc1
commit d6385ab852
6 changed files with 177 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
lib/server/chan.ml
View File

@ -23,43 +23,12 @@ let set_limit t n = t.chan_limit <- n
let key t = t.chan_key
let set_key t k = t.chan_key <- k
let members chan =
Dllist.fold_r (fun m xs -> m.mem_user :: xs) chan.members []
let register t ~router = Hashtbl.replace router.channels t.name_key t
let unregister t ~router = Hashtbl.remove router.channels t.name_key
let is_registered t ~router = Hashtbl.mem router.channels t.name_key
let members t =
Dllist.fold_r (fun m xs -> m.mem_user :: xs) t.members []
let no_members t =
Dllist.is_empty t.members
let register t ~router =
Hashtbl.replace router.channels t.name_key t
let unregister t ~router =
Hashtbl.remove router.channels t.name_key
let is_registered t ~router =
Hashtbl.mem router.channels t.name_key
let is_member t user =
let is_mem m = m.mem_chan == t in
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_in_chan = None;
} in
begin
m.mem_in_chan <- Some (Dllist.add_r m t.members);
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

204
lib/server/connection.ml
View File

@ -18,18 +18,6 @@ let make ~(router : Router.t) ~(addr : sockaddr) : t =
let outbox t = t.outbox
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];
User.part_all me;
(* TODO: BUG: unregister empty channels *)
User.unregister me ~router:t.router)
t.user;
Outbox.close t.outbox
(* TODO: configure these in some centralized location *)
let srv_host = "irc.tali.software"
let srv_ver = "0.0.0"
@ -82,49 +70,6 @@ let require_registered t : User.t result =
| None -> Error notregistered
(* init and quit *)
let about t me =
let who = Irc.Msg.prefix_string (User.prefix me) in
begin
reply t ("001", [Fmt.str "Welcome to the tali IRC network %s" who]);
reply t ("002", [Fmt.str "Your host is %s, running version %s" srv_host srv_ver]);
reply t ("003", [Fmt.str "This server was created %s" srv_created]);
reply t ("004", [srv_host; srv_ver; "iow"; "imnst"; "bklov"]);
reply t ("005", ["CASEMAPPING=ascii";
"CHANTYPES=#";
"CHANMODES=b,k,l,imstn";
"PREFIX=(ov)@+";
"are supported by this server"]);
end
let motd t =
begin
reply t ("375", [Fmt.str "- %s Message of the day - " srv_host]);
List.iter (fun ln -> reply t ("372", ["- " ^ ln])) srv_motd_lines;
reply t ("376", ["End of /MOTD command"]);
end
let welcome t me =
begin
about t me;
motd t;
end
let on_msg_motd t =
let* _me = require_registered t in
motd t;
Ok ()
let on_msg_quit t reason =
(* TODO: '''When connections are terminated by a client-sent QUIT command, servers
SHOULD prepend <reason> with the ASCII string "Quit: " when sending QUIT messages to
other clients''' *)
let reason = String.concat " " reason in
shutdown t ~reason;
Ok ()
(* modes *)
let set_user_mode user chg =
@ -316,6 +261,25 @@ let on_msg_names t name =
list_names t chan;
Ok ()
let join user chan ~router =
begin
(* TODO: check channel mode +k, +l *)
let msg = Irc.Msg.make "JOIN" [Chan.name chan] in
Router.relay msg ~from:user [`to_chan chan; `to_self];
Router.join chan user;
if not (Chan.is_registered chan ~router) then
begin
(* TODO: make founder +o / +q etc. *)
Chan.register chan ~router;
set_chan_mode chan ~from:user {
add = initial_user_mode;
rem = Irc.Mode.Set.empty;
};
end
end
let on_msg_join t name =
let* me = require_registered t in
(* TODO: keys parameter *)
@ -329,30 +293,34 @@ let on_msg_join t name =
debug (fun m -> m "making new channel %S" name);
Ok (Chan.make ~name)
in
(* TODO: check channel mode +k, +l *)
let msg = Irc.Msg.make "JOIN" [name] in
Router.relay msg ~from:me [`to_chan chan; `to_self];
Chan.join chan me;
if not (Chan.is_registered chan ~router:t.router) then
begin
Chan.register chan ~router:t.router;
set_chan_mode chan ~from:me {
add = initial_user_mode;
rem = Irc.Mode.Set.empty;
};
(* TODO: make founder +o / +q etc. *)
end;
join me chan ~router:t.router;
(* TODO: send channel topic *)
list_names t chan;
Ok ()
let part user chan ~router ~reason =
begin
let mem = Router.membership chan user in
Option.iter
(fun reason ->
let msg = Irc.Msg.make "PART" [Chan.name chan; reason] in
Router.relay msg ~from:user [`to_chan chan; `to_self])
reason;
Router.part mem;
(* TODO: if user was op then choose a new op? *)
if Chan.no_members chan then
begin
debug (fun m -> m "recycling empty channel %S" (Chan.name chan));
Chan.unregister chan ~router;
end
end
let on_msg_part t name =
let* me = require_registered t in
(* TODO: part reason *)
let* chan =
try
match Irc.name_type name with
@ -361,14 +329,77 @@ let on_msg_part t name =
with Not_found ->
Error (nosuchchannel 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_chan chan; `to_self];
Chan.part chan me;
if Chan.no_members chan then begin
debug (fun m -> m "recycling channel %S" name);
Chan.unregister chan ~router:t.router;
end;
try
part me chan ~router:t.router ~reason:(Some "Parting");
Ok ()
with Not_found ->
Error (notonchannel name)
(* welcome and quit *)
let about t me =
let who = Irc.Msg.prefix_string (User.prefix me) in
begin
reply t ("001", [Fmt.str "Welcome to the tali IRC network %s" who]);
reply t ("002", [Fmt.str "Your host is %s, running version %s" srv_host srv_ver]);
reply t ("003", [Fmt.str "This server was created %s" srv_created]);
reply t ("004", [srv_host; srv_ver; "iow"; "imnst"; "bklov"]);
reply t ("005", ["CASEMAPPING=ascii";
"CHANTYPES=#";
"CHANMODES=b,k,l,imstn";
"PREFIX=(ov)@+";
"are supported by this server"]);
end
let motd t =
begin
reply t ("375", [Fmt.str "- %s Message of the day - " srv_host]);
List.iter (fun ln -> reply t ("372", ["- " ^ ln])) srv_motd_lines;
reply t ("376", ["End of /MOTD command"]);
end
let welcome t me =
begin
about t me;
motd t;
end
let on_msg_motd t =
let* _me = require_registered t in
motd t;
Ok ()
let quit t reason =
begin
Option.iter
(fun user ->
let msg = Irc.Msg.make "QUIT" [User.nick user; reason] ~always_trailing:true in
Router.relay msg ~from:user [`to_interested];
List.iter
(part user ~router:t.router ~reason:None)
(User.channels user);
User.unregister user ~router:t.router;
t.user <- None)
t.user;
Outbox.close t.outbox;
end
let close t =
quit t "Client closed"
let on_msg_quit t reason =
(* TODO: '''When connections are terminated by a client-sent QUIT command, servers
SHOULD prepend <reason> with the ASCII string "Quit: " when sending QUIT messages to
other clients''' *)
let reason = match reason with
| [] -> "Quit"
| xs -> String.concat " " ("Quit:" :: xs)
in
quit t reason;
Ok ()
@ -381,7 +412,8 @@ let attempt_to_register t =
if not (Router.is_nick_available t.router nick) then
Error (nicknameinuse nick)
else
let me = User.make ~userinfo ~outbox:t.outbox in
let me = User.make nick ~userinfo ~outbox:t.outbox in
User.register me ~router:t.router;
t.user <- Some me;
welcome t me;
set_user_mode me {
@ -396,10 +428,14 @@ let user_set_nick t me nick =
if not (Router.is_nick_available t.router nick) then
Error (nicknameinuse nick)
else
begin
let msg = Irc.Msg.make "NICK" [nick] in
Router.relay msg ~from:me [`to_interested];
User.set_nick me nick ~router:t.router;
User.unregister me ~router:t.router;
User.set_nick me nick;
User.register me ~router:t.router;
Ok ()
end
let on_msg_nick t nick =
let* () =
@ -433,7 +469,7 @@ let dispatch t = function
| "NICK", nick :: _ when nick <> "" -> on_msg_nick t nick
| "NICK", _ -> Error nonicknamegiven
| "USER", unm :: _ :: _ :: rnm :: _ -> on_msg_user t unm rnm
| "QUIT", why -> on_msg_quit t why
| "QUIT", reason -> on_msg_quit t reason
| "MOTD", _ -> on_msg_motd t
| "PRIVMSG", ([] | "" :: _) -> Error norecipient
| "PRIVMSG", ([_] | _ :: "" :: _) -> Error notexttosend

28
lib/server/router.ml
View File

@ -1,6 +1,8 @@
open! Import
include Router_types
include (val Logging.sublogs logger "Router")
type t = router
let make () =
@ -33,3 +35,29 @@ let relay ~(from : user) (msg : Irc.Msg.t) tgts =
| `to_interested -> bcc from; List.iter bcc_channel (User.channels from))
tgts;
Outbox.Bcc.send_all msg
let join chan user =
let mem = {
mem_chan = chan;
mem_user = user;
mem_in_chan = None;
mem_in_user = None;
} in
begin
mem.mem_in_chan <- Some (Dllist.add_r mem chan.members);
mem.mem_in_user <- Some (Dllist.add_r mem user.membership);
end
let membership chan user =
Dllist.find_node_l (fun mem -> mem.mem_chan == chan)
user.membership |> Dllist.get
let part mem =
try
Dllist.remove (Option.get mem.mem_in_user);
Dllist.remove (Option.get mem.mem_in_chan);
mem.mem_in_user <- None;
mem.mem_in_chan <- None;
with Invalid_argument _ ->
warn (fun m -> m "part (%S,%S): already removed"
(Chan.name mem.mem_chan) (User.nick mem.mem_user))

8
lib/server/router_types.ml
View File

@ -2,14 +2,13 @@ open! Import
type string_ci = Case_insensitive of string [@@unboxed]
let string_ci s = Case_insensitive (String.lowercase_ascii s)
let empty_string_ci = Case_insensitive ""
type user = {
outbox : Outbox.t;
userinfo : Irc.userinfo;
mutable user_mode : Irc.Mode.Set.t;
mutable nick : Irc.name;
mutable nick_key : string_ci;
mutable user_mode : Irc.Mode.Set.t;
mutable membership : membership Dllist.t;
}
@ -21,7 +20,7 @@ and chan = {
mutable chan_mode : Irc.Mode.Set.t; (* +imstn *)
mutable chan_limit : int option; (* +l *)
mutable chan_key : string option; (* +k *)
(* TODO: +b, +o, +v *)
(* TODO: +b *)
(* TODO: creation time *)
}
@ -29,7 +28,8 @@ and membership = {
mem_user : user;
mem_chan : chan;
mutable mem_in_chan : membership Dllist.node option;
(* mutable mem_of_user : membership Dllist.node option; *)
mutable mem_in_user : membership Dllist.node option;
(* TODO: +o/+v (?) *)
}
type router = {

6
lib/server/server.ml
View File

@ -68,9 +68,9 @@ let handle_client (router : Router.t) (conn_fd : fd) (conn_addr : sockaddr) =
in
let reader = Lwt_stream.iter (Connection.on_msg conn) (reader conn_fd) in
let writer = writer conn_fd (Outbox.stream (Connection.outbox conn)) in
let shutdown () = Connection.shutdown conn in
Lwt.on_termination reader shutdown;
Lwt.on_termination writer shutdown;
let close () = Connection.close conn in
Lwt.on_termination reader close;
Lwt.on_termination writer close;
Lwt.finalize
(fun () -> writer)
(fun () ->

39
lib/server/user.ml
View File

@ -3,12 +3,12 @@ include Router_types
type t = user
let make ~userinfo ~outbox =
let make nick ~userinfo ~outbox =
{
outbox;
userinfo;
nick = "";
nick_key = empty_string_ci;
nick;
nick_key = string_ci nick;
user_mode = Irc.Mode.Set.empty;
membership = Dllist.create ();
}
@ -18,31 +18,18 @@ let nick t = t.nick
let mode t = t.user_mode
let set_mode t new_mode = t.user_mode <- new_mode
let prefix user =
Irc.Msg.User_prefix (user.nick, Some user.userinfo)
let channels user =
Dllist.fold_r (fun m xs -> m.mem_chan :: xs) user.membership []
let register t ~router =
Hashtbl.add router.users t.nick_key t
let unregister t ~router =
Hashtbl.remove router.users t.nick_key
let set_nick t new_nick ~router =
let set_nick t new_nick =
begin
unregister t ~router;
t.nick <- new_nick;
t.nick_key <- string_ci new_nick;
register t ~router;
end
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;
part_all t
| exception Dllist.Empty ->
()
let register t ~router = Hashtbl.add router.users t.nick_key t
let unregister t ~router = Hashtbl.remove router.users t.nick_key
let is_registered t ~router = Hashtbl.mem router.channels t.nick_key
let prefix t =
Irc.Msg.User_prefix (t.nick, Some t.userinfo)
let channels t =
Dllist.fold_r (fun m xs -> m.mem_chan :: xs) t.membership []