2024-01-07 20:54:39 +00:00
|
|
|
open! Import
|
2024-01-11 04:38:25 +00:00
|
|
|
open Result_syntax
|
2024-01-07 20:54:39 +00:00
|
|
|
|
2024-01-12 02:49:48 +00:00
|
|
|
include (val Logging.sublogs logger "Connection")
|
|
|
|
|
2024-01-07 20:54:39 +00:00
|
|
|
type t = {
|
2024-01-10 02:20:16 +00:00
|
|
|
router : Router.t;
|
2024-01-11 03:49:07 +00:00
|
|
|
addr : sockaddr;
|
2024-01-10 00:35:03 +00:00
|
|
|
outbox : Outbox.t;
|
2024-01-11 03:49:07 +00:00
|
|
|
mutable user : User.t option;
|
2024-01-08 05:39:39 +00:00
|
|
|
mutable pending_nick : string option;
|
2024-01-11 03:49:07 +00:00
|
|
|
mutable pending_userinfo : Irc.userinfo option;
|
2024-01-07 20:54:39 +00:00
|
|
|
}
|
|
|
|
|
2024-01-08 03:28:31 +00:00
|
|
|
let make ~(router : Router.t) ~(addr : sockaddr) : t =
|
2024-01-10 00:35:03 +00:00
|
|
|
let outbox = Outbox.make () in
|
2024-01-11 03:49:07 +00:00
|
|
|
{ router; addr; outbox; user = None; pending_nick = None; pending_userinfo = None }
|
2024-01-07 20:54:39 +00:00
|
|
|
|
2024-01-10 00:35:03 +00:00
|
|
|
let outbox t = t.outbox
|
2024-01-07 20:54:39 +00:00
|
|
|
|
2024-01-14 17:25:06 +00:00
|
|
|
(* TODO: configure these in some centralized location *)
|
2024-01-11 04:38:25 +00:00
|
|
|
let srv_host = "irc.tali.software"
|
|
|
|
let srv_ver = "0.0.0"
|
|
|
|
let srv_created = "Sun Jan 7 09:58:24 PM EST 2024"
|
|
|
|
let srv_motd_lines = [
|
|
|
|
"MEOW MEOW MEOW MEOW MEOW";
|
|
|
|
"meow meow meow meow meow";
|
|
|
|
"meowmeowmeowmeowmeowmeow";
|
|
|
|
]
|
|
|
|
|
2024-01-22 17:48:44 +00:00
|
|
|
let initial_user_mode = Irc.Mode.Set.of_string "iw"
|
|
|
|
let initial_chan_mode = Irc.Mode.Set.of_string "nst"
|
2024-01-18 17:29:36 +00:00
|
|
|
|
2024-01-11 04:38:25 +00:00
|
|
|
|
|
|
|
(* numeric replies *)
|
|
|
|
|
|
|
|
type reply = string * string list
|
|
|
|
|
2024-01-14 17:25:06 +00:00
|
|
|
type 'a result = ('a, reply) Result.t
|
|
|
|
|
2024-01-11 04:38:25 +00:00
|
|
|
let reply t (num, params) =
|
|
|
|
let prefix = Irc.Msg.Server_prefix srv_host in
|
|
|
|
let target = match t.user with
|
|
|
|
| Some me -> User.nick me
|
|
|
|
| None -> "*"
|
|
|
|
in
|
|
|
|
Outbox.send t.outbox
|
|
|
|
(Irc.Msg.make ~prefix num (target :: params))
|
|
|
|
|
2024-01-14 17:25:06 +00:00
|
|
|
let tryagain cmd = "263", [cmd; "Please wait a while and try again."]
|
2024-01-11 04:38:25 +00:00
|
|
|
let nosuchnick tgt = "401", [tgt; "No such nick/channel"]
|
|
|
|
let nosuchchannel tgt = "403", [tgt; "No such channel"]
|
|
|
|
let norecipient = "411", ["No recipient given (PRIVMSG)"]
|
|
|
|
let notexttosend = "412", ["No text to send"]
|
|
|
|
let unknowncommand cmd = "421", [cmd; "Unknown command"]
|
|
|
|
let nonicknamegiven = "431", ["No nickname given"]
|
|
|
|
let erroneusnickname nick = "432", [nick; "Erroneus nickname"]
|
|
|
|
let nicknameinuse nick = "433", [nick; "Nickname is already in use"]
|
|
|
|
let notonchannel chan = "442", [chan; "You're not on that channel"]
|
|
|
|
let notregistered = "451", ["You have not registered"]
|
|
|
|
let needmoreparams cmd = "461", [cmd; "Not enough parameters"]
|
|
|
|
let alreadyregistered = "462", ["Unauthorized command (already registered)"]
|
2024-01-20 16:19:29 +00:00
|
|
|
let modeunknownflag = "501", ["Didn't understand MODE command"]
|
2024-01-18 18:27:51 +00:00
|
|
|
let usersdontmatch_set = "502", ["Can't change mode for other users"]
|
|
|
|
let usersdontmatch_get = "502", ["Can't view mode for other users"]
|
2024-01-11 04:38:25 +00:00
|
|
|
|
2024-01-14 17:25:06 +00:00
|
|
|
let require_registered t : User.t result =
|
2024-01-11 03:49:07 +00:00
|
|
|
match t.user with
|
2024-01-11 04:38:25 +00:00
|
|
|
| Some me -> Ok me
|
|
|
|
| None -> Error notregistered
|
2024-01-07 20:54:39 +00:00
|
|
|
|
2024-01-08 03:28:31 +00:00
|
|
|
|
2024-01-14 17:25:06 +00:00
|
|
|
(* modes *)
|
|
|
|
|
2024-01-18 18:27:51 +00:00
|
|
|
let set_user_mode user chg =
|
|
|
|
let mode, chg =
|
|
|
|
Irc.Mode.Set.normalize
|
|
|
|
(User.mode user)
|
|
|
|
Irc.Mode.Set.{ chg with add = remove `o chg.add (* can't set +o *) }
|
|
|
|
in
|
|
|
|
if chg <> Irc.Mode.Set.no_change then
|
|
|
|
let modestr = Fmt.str "%a" Irc.Mode.Set.pp_change chg in
|
2024-01-22 17:48:44 +00:00
|
|
|
let msg = Irc.Msg.make "MODE" [User.nick user; modestr] in
|
2024-01-18 18:27:51 +00:00
|
|
|
begin
|
|
|
|
Router.relay msg ~from:user [`to_self];
|
|
|
|
User.set_mode user mode;
|
|
|
|
end
|
2024-01-18 17:29:36 +00:00
|
|
|
|
2024-01-18 18:28:48 +00:00
|
|
|
let set_chan_mode chan ~from chg =
|
|
|
|
let mode, chg = Irc.Mode.Set.normalize (Chan.mode chan) chg in
|
|
|
|
if chg <> Irc.Mode.Set.no_change then
|
|
|
|
let modestr = Fmt.str "%a" Irc.Mode.Set.pp_change chg in
|
2024-01-22 17:48:44 +00:00
|
|
|
let msg = Irc.Msg.make "MODE" [Chan.name chan; modestr] in
|
2024-01-18 18:28:48 +00:00
|
|
|
begin
|
|
|
|
Router.relay msg ~from [`to_chan chan; `to_self];
|
|
|
|
Chan.set_mode chan mode;
|
|
|
|
end
|
|
|
|
|
2024-01-20 16:19:29 +00:00
|
|
|
let set_chan_key chan ~from = function
|
2024-01-22 17:37:20 +00:00
|
|
|
| `set key ->
|
2024-01-20 16:19:29 +00:00
|
|
|
let msg = Irc.Msg.make "MODE" [Chan.name chan; "+k"; key] ~always_trailing:true in
|
|
|
|
begin
|
|
|
|
Router.relay msg ~from [`to_chan chan; `to_self];
|
|
|
|
Chan.set_key chan (Some key);
|
|
|
|
end
|
2024-01-22 17:37:20 +00:00
|
|
|
| `unset ->
|
2024-01-20 16:19:29 +00:00
|
|
|
if Chan.key chan <> None then
|
|
|
|
let msg = Irc.Msg.make "MODE" [Chan.name chan; "-k"; "*"] in
|
|
|
|
begin
|
|
|
|
Router.relay msg ~from [`to_chan chan; `to_self];
|
|
|
|
Chan.set_key chan None;
|
|
|
|
end
|
|
|
|
|
|
|
|
let set_chan_limit chan ~from = function
|
2024-01-22 17:37:20 +00:00
|
|
|
| `set lim ->
|
2024-01-20 16:19:29 +00:00
|
|
|
if Chan.limit chan <> Some lim then
|
|
|
|
let msg = Irc.Msg.make "MODE" [Chan.name chan; "+l"; string_of_int lim] in
|
|
|
|
begin
|
|
|
|
Router.relay msg ~from [`to_chan chan; `to_self];
|
|
|
|
Chan.set_limit chan (Some lim);
|
|
|
|
end
|
2024-01-22 17:37:20 +00:00
|
|
|
| `unset ->
|
2024-01-20 16:19:29 +00:00
|
|
|
if Chan.limit chan <> None then
|
|
|
|
let msg = Irc.Msg.make "MODE" [Chan.name chan; "-l"] in
|
|
|
|
begin
|
|
|
|
Router.relay msg ~from [`to_chan chan; `to_self];
|
|
|
|
Chan.set_limit chan None;
|
|
|
|
end
|
|
|
|
|
2024-01-18 18:27:51 +00:00
|
|
|
let on_get_user_mode user me =
|
|
|
|
let* () = if user != me then Error usersdontmatch_get else Ok () in
|
2024-01-18 17:29:36 +00:00
|
|
|
Ok [
|
2024-01-18 18:27:51 +00:00
|
|
|
"221", [Fmt.str "+%a" Irc.Mode.Set.pp (User.mode me)]
|
2024-01-18 17:29:36 +00:00
|
|
|
]
|
|
|
|
|
|
|
|
let on_set_user_mode user me modestr _args =
|
2024-01-22 17:37:20 +00:00
|
|
|
let* () = if user == me then Ok () else Error usersdontmatch_set in
|
2024-01-18 17:29:36 +00:00
|
|
|
let* chg = try Ok (Irc.Mode.Parse.user_modes modestr)
|
2024-01-14 17:46:42 +00:00
|
|
|
with Irc.Mode.Parse.Error ->
|
2024-01-18 17:29:36 +00:00
|
|
|
(* TODO: "If one or more modes sent are not implemented on the server, the server
|
|
|
|
MUST apply the modes that are implemented, and then send the ERR_UMODEUNKNOWNFLAG
|
|
|
|
(501) in reply along with the MODE message." *)
|
2024-01-14 17:46:42 +00:00
|
|
|
Error modeunknownflag
|
|
|
|
in
|
2024-01-18 18:27:51 +00:00
|
|
|
set_user_mode me chg;
|
2024-01-18 18:28:48 +00:00
|
|
|
Ok []
|
2024-01-14 17:25:06 +00:00
|
|
|
|
2024-01-18 18:28:48 +00:00
|
|
|
let on_get_chan_mode chan _me =
|
2024-01-22 17:37:20 +00:00
|
|
|
let rpls = [
|
2024-01-20 16:19:29 +00:00
|
|
|
["324", [Chan.name chan; Fmt.str "+%a" Irc.Mode.Set.pp (Chan.mode chan)]];
|
|
|
|
|
|
|
|
begin match Chan.limit chan with
|
|
|
|
| Some lim -> ["324", [Chan.name chan; "+l"; string_of_int lim]]
|
|
|
|
| None -> []
|
|
|
|
end;
|
|
|
|
|
|
|
|
(* TODO: only display key if priveledged enough to see it *)
|
|
|
|
begin match Chan.key chan with
|
|
|
|
| Some key -> ["324", [Chan.name chan; "+k"; key]]
|
|
|
|
| None -> []
|
|
|
|
end;
|
|
|
|
|
2024-01-18 18:28:48 +00:00
|
|
|
(* TODO: RPL_CREATIONTIME (329) *)
|
2024-01-20 16:19:29 +00:00
|
|
|
] in
|
|
|
|
Ok (List.flatten rpls)
|
2024-01-14 17:25:06 +00:00
|
|
|
|
2024-01-18 17:29:36 +00:00
|
|
|
let on_set_chan_mode chan me modestr args =
|
2024-01-18 18:28:48 +00:00
|
|
|
(* TODO: If <modestring> is given, the user sending the command MUST have appropriate
|
|
|
|
channel privileges on the target channel to change the modes given. If a user does
|
|
|
|
not have appropriate privileges to change modes on the target channel, the server
|
|
|
|
MUST NOT process the message, and ERR_CHANOPRIVSNEEDED (482) numeric is returned. *)
|
|
|
|
let _ = me, chan in
|
|
|
|
|
|
|
|
let* chg = try Ok (Irc.Mode.Parse.chan_modes modestr args)
|
|
|
|
with Irc.Mode.Parse.Error ->
|
|
|
|
(* TODO: "If one or more modes sent are not implemented on the server, the server
|
|
|
|
MUST apply the modes that are implemented, and then send the ERR_UMODEUNKNOWNFLAG
|
|
|
|
(501) in reply along with the MODE message." *)
|
|
|
|
Error modeunknownflag
|
|
|
|
in
|
|
|
|
|
2024-01-20 16:19:29 +00:00
|
|
|
set_chan_mode chan ~from:me chg.chan_modes;
|
|
|
|
Option.iter (set_chan_key chan ~from:me) chg.chan_key;
|
|
|
|
Option.iter (set_chan_limit chan ~from:me) chg.chan_limit;
|
2024-01-22 17:48:44 +00:00
|
|
|
(* TODO: ban/op/voice *)
|
2024-01-18 18:28:48 +00:00
|
|
|
|
|
|
|
Ok []
|
2024-01-14 17:25:06 +00:00
|
|
|
|
|
|
|
let on_msg_mode t name args =
|
|
|
|
let* me = require_registered t in
|
2024-01-18 17:29:36 +00:00
|
|
|
let* on_set, on_get =
|
2024-01-14 17:25:06 +00:00
|
|
|
try
|
|
|
|
match Irc.name_type name with
|
|
|
|
| `nick ->
|
|
|
|
let u = Router.find_user t.router name in
|
2024-01-18 17:29:36 +00:00
|
|
|
Ok (on_set_user_mode u, on_get_user_mode u)
|
2024-01-14 17:25:06 +00:00
|
|
|
| `chan ->
|
|
|
|
let c = Router.find_chan t.router name in
|
2024-01-18 17:29:36 +00:00
|
|
|
Ok (on_set_chan_mode c, on_get_chan_mode c)
|
2024-01-14 17:25:06 +00:00
|
|
|
| `invalid -> raise Not_found
|
|
|
|
with Not_found ->
|
|
|
|
Error (nosuchnick name)
|
|
|
|
in
|
2024-01-22 17:48:44 +00:00
|
|
|
let* rpls =
|
2024-01-18 18:28:48 +00:00
|
|
|
match args with
|
|
|
|
| [] -> on_get me
|
|
|
|
| modestr :: args -> on_set me modestr args
|
|
|
|
in
|
2024-01-22 17:48:44 +00:00
|
|
|
List.iter (reply t) rpls;
|
|
|
|
Ok ()
|
2024-01-18 18:28:48 +00:00
|
|
|
|
2024-01-22 17:37:20 +00:00
|
|
|
|
|
|
|
(* messages and channels *)
|
|
|
|
|
|
|
|
let on_msg_privmsg t name txt =
|
|
|
|
let* me = require_registered t in
|
|
|
|
let* tgt =
|
|
|
|
try
|
|
|
|
match Irc.name_type name with
|
|
|
|
| `chan -> Ok (`chan (Router.find_chan t.router name))
|
|
|
|
| _ -> Ok (`user (Router.find_user t.router name))
|
|
|
|
with Not_found ->
|
|
|
|
Error (nosuchnick name)
|
|
|
|
in
|
|
|
|
(* TODO: check if user is away *)
|
|
|
|
(* TODO: check if channel is +n and user is not a member *)
|
|
|
|
(* TODO: check if channel is +m and user is not priviledged *)
|
|
|
|
(* TODO: check if channel is +b <user> *)
|
|
|
|
let name, dst =
|
|
|
|
match tgt with
|
|
|
|
| `chan c -> Chan.name c, [`to_chan c]
|
|
|
|
| `user u -> User.nick u, [`to_user u]
|
|
|
|
in
|
|
|
|
let msg = Irc.Msg.make "PRIVMSG" [name; txt] ~always_trailing:true in
|
|
|
|
Router.relay msg ~from:me dst;
|
|
|
|
Ok ()
|
|
|
|
|
|
|
|
let list_names t chan =
|
|
|
|
begin
|
|
|
|
List.iter
|
|
|
|
(fun user ->
|
|
|
|
(* TODO: check if user is +i and not in channel with them *)
|
2024-01-22 17:48:44 +00:00
|
|
|
(* ("=", 0x3D) - Public channel. *)
|
|
|
|
(* ("@", 0x40) - Secret channel (secret channel mode "+s"). *)
|
2024-01-22 17:37:20 +00:00
|
|
|
reply t ("353", ["@"; Chan.name chan; User.nick user]))
|
|
|
|
(Chan.members chan);
|
|
|
|
reply t ("366", [Chan.name chan; "End of NAMES list"])
|
|
|
|
end
|
|
|
|
|
|
|
|
let on_msg_names t name =
|
|
|
|
let* _me = require_registered t in
|
|
|
|
let* chan =
|
|
|
|
try
|
|
|
|
match Irc.name_type name with
|
|
|
|
| `chan -> Ok (Router.find_chan t.router name)
|
|
|
|
| _ -> Error (nosuchchannel name)
|
|
|
|
with Not_found ->
|
|
|
|
Error (nosuchchannel name)
|
|
|
|
in
|
|
|
|
(* TODO: check if channel is +s and user not member of channel *)
|
|
|
|
list_names t chan;
|
|
|
|
Ok ()
|
|
|
|
|
2024-01-23 18:13:41 +00:00
|
|
|
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
|
|
|
|
|
2024-01-22 17:37:20 +00:00
|
|
|
let on_msg_join t name =
|
|
|
|
let* me = require_registered t in
|
|
|
|
(* TODO: keys parameter *)
|
|
|
|
(* TODO: "0" parameter means part from all channels *)
|
|
|
|
let* chan =
|
|
|
|
try
|
|
|
|
match Irc.name_type name with
|
|
|
|
| `chan -> Ok (Router.find_chan t.router name)
|
|
|
|
| _ -> Error (nosuchchannel name)
|
|
|
|
with Not_found ->
|
|
|
|
debug (fun m -> m "making new channel %S" name);
|
|
|
|
Ok (Chan.make ~name)
|
|
|
|
in
|
2024-01-23 18:13:41 +00:00
|
|
|
join me chan ~router:t.router;
|
|
|
|
(* TODO: send channel topic *)
|
|
|
|
list_names t chan;
|
|
|
|
Ok ()
|
2024-01-22 17:37:20 +00:00
|
|
|
|
2024-01-23 18:13:41 +00:00
|
|
|
let part user chan ~router ~reason =
|
|
|
|
begin
|
|
|
|
let mem = Router.membership chan user in
|
2024-01-22 17:37:20 +00:00
|
|
|
|
2024-01-23 18:13:41 +00:00
|
|
|
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;
|
2024-01-22 17:37:20 +00:00
|
|
|
|
2024-01-23 18:13:41 +00:00
|
|
|
Router.part mem;
|
2024-01-22 17:37:20 +00:00
|
|
|
|
2024-01-23 18:13:41 +00:00
|
|
|
(* 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
|
2024-01-22 17:37:20 +00:00
|
|
|
|
|
|
|
let on_msg_part t name =
|
|
|
|
let* me = require_registered t in
|
|
|
|
let* chan =
|
|
|
|
try
|
|
|
|
match Irc.name_type name with
|
|
|
|
| `chan -> Ok (Router.find_chan t.router name)
|
|
|
|
| `nick | `invalid -> raise Not_found
|
|
|
|
with Not_found ->
|
|
|
|
Error (nosuchchannel name)
|
|
|
|
in
|
2024-01-23 18:13:41 +00:00
|
|
|
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 ()
|
|
|
|
|
2024-01-23 18:31:06 +00:00
|
|
|
let quit t me ~reason =
|
2024-01-23 18:13:41 +00:00
|
|
|
begin
|
2024-01-23 18:31:06 +00:00
|
|
|
let msg = Irc.Msg.make "QUIT" [User.nick me; reason] ~always_trailing:true in
|
|
|
|
Router.relay msg ~from:me [`to_interested];
|
2024-01-23 18:13:41 +00:00
|
|
|
|
2024-01-23 18:31:06 +00:00
|
|
|
List.iter
|
|
|
|
(part me ~router:t.router ~reason:None)
|
|
|
|
(User.channels me);
|
2024-01-23 18:13:41 +00:00
|
|
|
|
2024-01-23 18:31:06 +00:00
|
|
|
User.unregister me ~router:t.router;
|
|
|
|
t.user <- None
|
2024-01-23 18:13:41 +00:00
|
|
|
end
|
|
|
|
|
2024-01-23 18:31:06 +00:00
|
|
|
let close ?(reason = "Client closed") t =
|
|
|
|
Option.iter (quit t ~reason) t.user;
|
|
|
|
Outbox.close t.outbox
|
2024-01-23 18:13:41 +00:00
|
|
|
|
|
|
|
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
|
2024-01-23 18:31:06 +00:00
|
|
|
close t ~reason;
|
2024-01-22 17:37:20 +00:00
|
|
|
Ok ()
|
2024-01-18 18:28:48 +00:00
|
|
|
|
2024-01-14 17:25:06 +00:00
|
|
|
|
2024-01-22 17:30:26 +00:00
|
|
|
(* user registration *)
|
2024-01-14 17:25:06 +00:00
|
|
|
|
2024-01-22 17:30:26 +00:00
|
|
|
let attempt_to_register t =
|
|
|
|
match t.pending_nick, t.pending_userinfo with
|
|
|
|
| Some nick, Some userinfo ->
|
|
|
|
t.pending_nick <- None;
|
2024-01-22 17:48:44 +00:00
|
|
|
if not (Router.is_nick_available t.router nick) then
|
|
|
|
Error (nicknameinuse nick)
|
|
|
|
else
|
2024-01-23 18:13:41 +00:00
|
|
|
let me = User.make nick ~userinfo ~outbox:t.outbox in
|
|
|
|
User.register me ~router:t.router;
|
2024-01-22 17:48:44 +00:00
|
|
|
t.user <- Some me;
|
|
|
|
welcome t me;
|
|
|
|
set_user_mode me {
|
|
|
|
add = initial_user_mode;
|
|
|
|
rem = Irc.Mode.Set.empty;
|
|
|
|
};
|
|
|
|
Ok ()
|
2024-01-22 17:30:26 +00:00
|
|
|
| _, _ ->
|
|
|
|
Ok ()
|
2024-01-14 17:25:06 +00:00
|
|
|
|
2024-01-22 17:48:44 +00:00
|
|
|
let user_set_nick t me nick =
|
|
|
|
if not (Router.is_nick_available t.router nick) then
|
|
|
|
Error (nicknameinuse nick)
|
|
|
|
else
|
2024-01-23 18:13:41 +00:00
|
|
|
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
|
2024-01-22 17:48:44 +00:00
|
|
|
|
2024-01-22 17:30:26 +00:00
|
|
|
let on_msg_nick t nick =
|
|
|
|
let* () =
|
|
|
|
match Irc.name_type nick with
|
|
|
|
| `nick -> Ok ()
|
|
|
|
| `chan | `invalid -> Error (erroneusnickname nick)
|
|
|
|
in
|
|
|
|
match t.user with
|
|
|
|
| Some me ->
|
2024-01-22 17:48:44 +00:00
|
|
|
user_set_nick t me nick
|
2024-01-22 17:30:26 +00:00
|
|
|
| None ->
|
|
|
|
t.pending_nick <- Some nick;
|
|
|
|
attempt_to_register t
|
2024-01-07 20:54:39 +00:00
|
|
|
|
2024-01-22 17:30:26 +00:00
|
|
|
let on_msg_user t username realname =
|
|
|
|
match t.user with
|
|
|
|
| Some _me -> Error alreadyregistered
|
|
|
|
| None ->
|
|
|
|
(* TODO: configure hiding hostnames *)
|
|
|
|
let hostname = match t.addr with
|
|
|
|
| ADDR_INET (ia, _) -> Unix.string_of_inet_addr ia
|
|
|
|
| ADDR_UNIX path -> path
|
|
|
|
in
|
|
|
|
t.pending_userinfo <- Some { username; realname; hostname };
|
|
|
|
attempt_to_register t
|
2024-01-08 05:31:05 +00:00
|
|
|
|
2024-01-07 20:54:39 +00:00
|
|
|
|
2024-01-08 03:28:31 +00:00
|
|
|
(* message parsing *)
|
2024-01-07 20:54:39 +00:00
|
|
|
|
2024-01-11 05:13:08 +00:00
|
|
|
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
|
2024-01-23 18:13:41 +00:00
|
|
|
| "QUIT", reason -> on_msg_quit t reason
|
2024-01-11 05:13:08 +00:00
|
|
|
| "MOTD", _ -> on_msg_motd t
|
2024-01-12 03:14:23 +00:00
|
|
|
| "PRIVMSG", ([] | "" :: _) -> Error norecipient
|
|
|
|
| "PRIVMSG", ([_] | _ :: "" :: _) -> Error notexttosend
|
2024-01-11 05:13:08 +00:00
|
|
|
| "PRIVMSG", tgt :: msg :: _ -> on_msg_privmsg t tgt msg
|
|
|
|
| "JOIN", tgt :: _ when tgt <> "" -> on_msg_join t tgt
|
|
|
|
| "NAMES", tgt :: _ when tgt <> "" -> on_msg_names t tgt
|
|
|
|
| "PART", tgt :: _ when tgt <> "" -> on_msg_part t tgt
|
2024-01-14 17:25:06 +00:00
|
|
|
| "MODE", tgt :: args when tgt <> "" -> on_msg_mode t tgt args
|
|
|
|
| ("USER" | "JOIN" | "NAMES" | "PART" | "MODE") as cmd, _ ->
|
2024-01-11 05:13:08 +00:00
|
|
|
Error (needmoreparams cmd)
|
|
|
|
| cmd, _ ->
|
|
|
|
Error (unknowncommand cmd)
|
|
|
|
|
|
|
|
let split_command_params cmd params =
|
|
|
|
match cmd, params with
|
|
|
|
| ("PRIVMSG" | "JOIN" | "NAMES" | "PART"), tgts :: rest
|
|
|
|
when String.contains tgts ',' ->
|
|
|
|
(* TODO: "JOIN" should be handled specially *)
|
|
|
|
String.split_on_char ',' tgts |>
|
|
|
|
List.map (fun tgt -> cmd, tgt :: rest)
|
|
|
|
| _ ->
|
|
|
|
[cmd, params]
|
|
|
|
|
|
|
|
let pp_args ppf (cmd, params) =
|
2024-01-12 02:49:48 +00:00
|
|
|
Fmt.pf ppf "@[%s@ %a@]" cmd (Fmt.list (Fmt.fmt "%S") ~sep:Fmt.sp) params
|
2024-01-11 05:13:08 +00:00
|
|
|
|
2024-01-07 21:29:12 +00:00
|
|
|
let on_msg t (msg : Irc.Msg.t) : unit =
|
2024-01-11 05:13:08 +00:00
|
|
|
split_command_params msg.command msg.params |>
|
|
|
|
List.iter
|
|
|
|
(fun args ->
|
2024-01-12 03:33:40 +00:00
|
|
|
trace (fun m -> m "@[%a:@ %a@]" pp_sockaddr t.addr pp_args args);
|
2024-01-11 05:13:08 +00:00
|
|
|
match dispatch t args with
|
|
|
|
| Ok () -> ()
|
|
|
|
| Error err -> reply t err)
|