302 lines
9.0 KiB
OCaml
302 lines
9.0 KiB
OCaml
open! Import
|
|
open Result_syntax
|
|
module User = Router.User
|
|
module Chan = Router.Chan
|
|
|
|
type t = {
|
|
router : Router.t;
|
|
addr : sockaddr;
|
|
outbox : Outbox.t;
|
|
mutable user : User.t option;
|
|
mutable pending_nick : string option;
|
|
mutable pending_userinfo : Irc.userinfo option;
|
|
}
|
|
|
|
let make ~(router : Router.t) ~(addr : sockaddr) : t =
|
|
let outbox = Outbox.make () in
|
|
{ router; addr; outbox; user = None; pending_nick = None; pending_userinfo = None }
|
|
|
|
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 me);
|
|
User.part_all me;
|
|
(* TODO: BUG: unregister empty channels *)
|
|
User.unregister me ~router:t.router)
|
|
t.user;
|
|
Outbox.close t.outbox
|
|
|
|
|
|
(* TODO: configure these *)
|
|
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";
|
|
]
|
|
|
|
|
|
(* numeric replies *)
|
|
|
|
type reply = string * string list
|
|
|
|
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))
|
|
|
|
let welcome 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
|
|
|
|
(* errors *)
|
|
|
|
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)"]
|
|
|
|
|
|
(* user registration *)
|
|
|
|
let require_registered t =
|
|
match t.user with
|
|
| Some me -> Ok me
|
|
| None -> Error notregistered
|
|
|
|
let attempt_to_register t =
|
|
match t.pending_nick, t.pending_userinfo with
|
|
| Some nick, Some userinfo ->
|
|
t.pending_nick <- None;
|
|
let me = User.make ~userinfo ~outbox:t.outbox in
|
|
begin match User.set_nick me nick ~router:t.router with
|
|
| `nick_in_use -> Error (nicknameinuse nick)
|
|
| `nick_set ->
|
|
t.user <- Some me;
|
|
welcome t me;
|
|
motd t;
|
|
(* TODO: get "actual" user mode *)
|
|
let msg = Irc.Msg.make "MODE" [nick; "+iw"] in
|
|
Router.relay msg ~from:me `to_self;
|
|
Ok ()
|
|
end
|
|
| _, _ ->
|
|
Ok ()
|
|
|
|
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 ->
|
|
begin
|
|
let msg = Irc.Msg.make "NICK" [nick] in
|
|
match
|
|
User.set_nick me nick
|
|
~router:t.router
|
|
~success_callback:(fun () -> Router.relay msg ~from:me (`to_interested me))
|
|
with
|
|
| `nick_in_use -> Error (nicknameinuse nick)
|
|
| `nick_set -> Ok ()
|
|
end
|
|
| None ->
|
|
t.pending_nick <- Some nick;
|
|
attempt_to_register t
|
|
|
|
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
|
|
|
|
|
|
(* messages and channels *)
|
|
|
|
let on_msg_privmsg t tgt txt =
|
|
let* me = require_registered t in
|
|
let* dst =
|
|
try
|
|
match Irc.name_type tgt with
|
|
| `chan -> Ok (`to_chan (Router.find_chan t.router tgt))
|
|
| _ -> Ok (`to_user (Router.find_user t.router tgt))
|
|
with Not_found ->
|
|
Error (nosuchnick tgt)
|
|
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 msg = Irc.Msg.make "PRIVMSG" [tgt; 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 *)
|
|
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 ()
|
|
|
|
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 ->
|
|
Logs.debug (fun m -> m "making new channel %S" name);
|
|
let chan = Chan.make ~name in
|
|
Chan.register chan ~router:t.router;
|
|
(* TODO: make user +o *)
|
|
Ok chan
|
|
in
|
|
(* TODO: check if channel is +k *)
|
|
Chan.join chan me;
|
|
let msg = Irc.Msg.make "JOIN" [name] in
|
|
Router.relay msg ~from:me `to_self;
|
|
Router.relay msg ~from:me (`to_chan chan);
|
|
(* TODO: send channel topic *)
|
|
list_names t chan;
|
|
Ok ()
|
|
|
|
let on_msg_part t name =
|
|
let* me = require_registered t in
|
|
(* TODO: part reason *)
|
|
let* chan =
|
|
try
|
|
match Irc.name_type name with
|
|
| `chan -> Ok (Router.find_chan t.router name)
|
|
| `nick | `invalid -> Error (nosuchchannel 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_self;
|
|
Router.relay msg ~from:me (`to_chan chan);
|
|
Chan.part chan me;
|
|
if Chan.no_members chan then begin
|
|
Logs.debug (fun m -> m "recycling channel %S" name);
|
|
Chan.unregister chan ~router:t.router;
|
|
end;
|
|
Ok ()
|
|
|
|
|
|
(* misc *)
|
|
|
|
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 ()
|
|
|
|
|
|
(* message parsing *)
|
|
|
|
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
|
|
| "MOTD", _ -> on_msg_motd t
|
|
| "PRIVMSG", tgt :: msg :: _ -> on_msg_privmsg t tgt msg
|
|
| "PRIVMSG", [_] -> Error notexttosend | "PRIVMSG", [] -> Error norecipient
|
|
| "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
|
|
| ("USER" | "JOIN" | "NAMES" | "PART") as cmd, _ ->
|
|
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) =
|
|
Fmt.pf ppf "%s %a" cmd (Fmt.list (Fmt.fmt "%S") ~sep:Fmt.sp) params
|
|
|
|
let on_msg t (msg : Irc.Msg.t) : unit =
|
|
split_command_params msg.command msg.params |>
|
|
List.iter
|
|
(fun args ->
|
|
Logs.debug (fun m -> m "%a: %a" pp_sockaddr t.addr pp_args args);
|
|
match dispatch t args with
|
|
| Ok () -> ()
|
|
| Error err -> reply t err)
|