From d6385ab8522ee91a7f5c38c4cbbf830a96192e41 Mon Sep 17 00:00:00 2001 From: tali Date: Tue, 23 Jan 2024 13:13:41 -0500 Subject: [PATCH] big huge refactor of channel join/part logic --- lib/server/chan.ml | 43 ++------ lib/server/connection.ml | 210 ++++++++++++++++++++++--------------- lib/server/router.ml | 28 +++++ lib/server/router_types.ml | 8 +- lib/server/server.ml | 6 +- lib/server/user.ml | 39 +++---- 6 files changed, 177 insertions(+), 157 deletions(-) diff --git a/lib/server/chan.ml b/lib/server/chan.ml index 4ad8570..6dd9841 100644 --- a/lib/server/chan.ml +++ b/lib/server/chan.ml @@ -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 - diff --git a/lib/server/connection.ml b/lib/server/connection.ml index a446979..7ea973a 100644 --- a/lib/server/connection.ml +++ b/lib/server/connection.ml @@ -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 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 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 - let msg = Irc.Msg.make "NICK" [nick] in - Router.relay msg ~from:me [`to_interested]; - User.set_nick me nick ~router:t.router; - Ok () + begin + let msg = Irc.Msg.make "NICK" [nick] in + Router.relay msg ~from:me [`to_interested]; + 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 diff --git a/lib/server/router.ml b/lib/server/router.ml index 9763ebb..026d183 100644 --- a/lib/server/router.ml +++ b/lib/server/router.ml @@ -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)) diff --git a/lib/server/router_types.ml b/lib/server/router_types.ml index 3c2adac..328c95c 100644 --- a/lib/server/router_types.ml +++ b/lib/server/router_types.ml @@ -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 = { diff --git a/lib/server/server.ml b/lib/server/server.ml index 500158a..e86dbd6 100644 --- a/lib/server/server.ml +++ b/lib/server/server.ml @@ -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 () -> diff --git a/lib/server/user.ml b/lib/server/user.ml index 22c8f89..44a458a 100644 --- a/lib/server/user.ml +++ b/lib/server/user.ml @@ -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 []