move server info and config to Server_info
This commit is contained in:
parent
d3763b1204
commit
aeeefeaf04
|
|
@ -4,5 +4,7 @@ Logging.init_pretty_writer stderr
|
|||
Lwt_main.run
|
||||
(Server.run {
|
||||
port = 6667;
|
||||
tcp_listen_backlog = 8
|
||||
tcp_listen_backlog = 8;
|
||||
hostname = "irc.tali.software";
|
||||
(* TODO: motd *)
|
||||
})
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ include (val Logging.sublogs logger "Connection")
|
|||
|
||||
type t = {
|
||||
router : Router.t;
|
||||
server_info : Server_info.t;
|
||||
addr : sockaddr;
|
||||
outbox : Outbox.t;
|
||||
mutable user : User.t option;
|
||||
|
|
@ -12,25 +13,18 @@ type t = {
|
|||
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 make ~router ~server_info ~addr = {
|
||||
router;
|
||||
server_info;
|
||||
addr;
|
||||
outbox = Outbox.make ();
|
||||
user = None;
|
||||
pending_nick = None;
|
||||
pending_userinfo = None;
|
||||
}
|
||||
|
||||
let outbox t = t.outbox
|
||||
|
||||
(* TODO: configure these in some centralized location *)
|
||||
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";
|
||||
]
|
||||
|
||||
let initial_user_mode = Irc.Mode.Set.of_string "iw"
|
||||
let initial_chan_mode = Irc.Mode.Set.of_string "nst"
|
||||
|
||||
|
||||
(* numeric replies *)
|
||||
|
||||
|
|
@ -39,8 +33,9 @@ type reply = string * string list
|
|||
type 'a result = ('a, reply) Result.t
|
||||
|
||||
let reply t (num, params) =
|
||||
let prefix = Irc.Msg.Server_prefix srv_host in
|
||||
let target = match t.user with
|
||||
let prefix = Server_info.prefix t.server_info in
|
||||
let target =
|
||||
match t.user with
|
||||
| Some me -> User.nick me
|
||||
| None -> "*"
|
||||
in
|
||||
|
|
@ -72,11 +67,11 @@ let require_registered t : User.t result =
|
|||
|
||||
(* modes *)
|
||||
|
||||
let set_user_mode user chg =
|
||||
let set_user_mode ?(add = Irc.Mode.Set.empty) ?(rem = Irc.Mode.Set.empty) user =
|
||||
let mode, chg =
|
||||
Irc.Mode.Set.normalize
|
||||
(User.mode user)
|
||||
Irc.Mode.Set.{ chg with add = remove `o chg.add (* can't set +o *) }
|
||||
{ add = Irc.Mode.Set.remove `o add; rem }
|
||||
in
|
||||
if chg <> Irc.Mode.Set.no_change then
|
||||
let modestr = Fmt.str "%a" Irc.Mode.Set.pp_change chg in
|
||||
|
|
@ -86,8 +81,12 @@ let set_user_mode user chg =
|
|||
User.set_mode user mode;
|
||||
end
|
||||
|
||||
let set_chan_mode chan ~from chg =
|
||||
let mode, chg = Irc.Mode.Set.normalize (Chan.mode chan) chg in
|
||||
let set_chan_mode ~from ?(add = Irc.Mode.Set.empty) ?(rem = Irc.Mode.Set.empty) chan =
|
||||
let mode, chg =
|
||||
Irc.Mode.Set.normalize
|
||||
(Chan.mode chan)
|
||||
{ add; rem }
|
||||
in
|
||||
if chg <> Irc.Mode.Set.no_change then
|
||||
let modestr = Fmt.str "%a" Irc.Mode.Set.pp_change chg in
|
||||
let msg = Irc.Msg.make "MODE" [Chan.name chan; modestr] in
|
||||
|
|
@ -142,7 +141,7 @@ let on_set_user_mode user me modestr _args =
|
|||
(501) in reply along with the MODE message." *)
|
||||
Error modeunknownflag
|
||||
in
|
||||
set_user_mode me chg;
|
||||
set_user_mode me ~add:chg.add ~rem:chg.rem;
|
||||
Ok []
|
||||
|
||||
let on_get_chan_mode chan _me =
|
||||
|
|
@ -179,7 +178,7 @@ let on_set_chan_mode chan me modestr args =
|
|||
Error modeunknownflag
|
||||
in
|
||||
|
||||
set_chan_mode chan ~from:me chg.chan_modes;
|
||||
set_chan_mode chan ~from:me ~add:chg.chan_modes.add ~rem:chg.chan_modes.rem;
|
||||
Option.iter (set_chan_key chan ~from:me) chg.chan_key;
|
||||
Option.iter (set_chan_limit chan ~from:me) chg.chan_limit;
|
||||
(* TODO: ban/op/voice *)
|
||||
|
|
@ -261,22 +260,21 @@ let on_msg_names t name =
|
|||
list_names t chan;
|
||||
Ok ()
|
||||
|
||||
let join user chan ~router =
|
||||
let join t user chan =
|
||||
begin
|
||||
(* TODO: check if already a member *)
|
||||
(* 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
|
||||
if not (Chan.is_registered chan ~router:t.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;
|
||||
};
|
||||
Chan.register chan ~router:t.router;
|
||||
set_chan_mode chan ~from:user
|
||||
~add:(Server_info.conf t.server_info).init_cmode;
|
||||
end
|
||||
end
|
||||
|
||||
|
|
@ -293,15 +291,17 @@ let on_msg_join t name =
|
|||
debug (fun m -> m "making new channel %S" name);
|
||||
Ok (Chan.make ~name)
|
||||
in
|
||||
join me chan ~router:t.router;
|
||||
join t me chan;
|
||||
(* TODO: send channel topic *)
|
||||
list_names t chan;
|
||||
Ok ()
|
||||
|
||||
let part user chan ~router ~reason =
|
||||
let part t user chan ~reason =
|
||||
let mem = Router.membership chan user in
|
||||
begin
|
||||
if User.is_registered user ~router then
|
||||
(* edge case: don't relay PART messages if the user is QUIT'ing *)
|
||||
(* FIXME: this will need to be changed again to handle KICK, i think *)
|
||||
if User.is_registered user ~router:t.router then
|
||||
begin
|
||||
let always_trailing = Option.is_some reason in
|
||||
let reason = Option.to_list reason in
|
||||
|
|
@ -316,7 +316,7 @@ let part user chan ~router ~reason =
|
|||
if Chan.no_members chan then
|
||||
begin
|
||||
debug (fun m -> m "recycling empty channel %S" (Chan.name chan));
|
||||
Chan.unregister chan ~router;
|
||||
Chan.unregister chan ~router:t.router;
|
||||
end
|
||||
end
|
||||
|
||||
|
|
@ -335,7 +335,7 @@ let on_msg_part t name reason =
|
|||
Error (nosuchchannel name)
|
||||
in
|
||||
try
|
||||
part me chan ~router:t.router ~reason;
|
||||
part t me chan ~reason;
|
||||
Ok ()
|
||||
with Not_found ->
|
||||
Error (notonchannel name)
|
||||
|
|
@ -345,22 +345,28 @@ let on_msg_part t name reason =
|
|||
|
||||
let about t me =
|
||||
let who = Irc.Msg.prefix_string (User.prefix me) in
|
||||
let s_hostname = Server_info.hostname t.server_info in
|
||||
let s_version = Server_info.version t.server_info in
|
||||
let s_created = Server_info.created t.server_info in
|
||||
let conf = Server_info.conf t.server_info in
|
||||
let modes l = String.of_seq (List.to_seq l |> Seq.map Irc.Mode.to_char) in
|
||||
let umodes = modes conf.all_umodes in
|
||||
let cmodes = modes conf.all_cmodes in
|
||||
let pmodes = modes conf.all_pmodes 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"]);
|
||||
reply t ("002", [Fmt.str "Your host is %s, running version %s" s_hostname s_version]);
|
||||
reply t ("003", [Fmt.str "This server was created %s" s_created]);
|
||||
reply t ("004", [s_hostname; s_version; umodes; cmodes; pmodes]);
|
||||
reply t ("005", conf.isupport);
|
||||
end
|
||||
|
||||
let motd t =
|
||||
let s_hostname = Server_info.hostname t.server_info in
|
||||
let s_motd = Server_info.motd t.server_info in
|
||||
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 ("375", [Fmt.str "- %s Message of the day - " s_hostname]);
|
||||
List.iter (fun ln -> reply t ("372", ["- " ^ ln])) s_motd;
|
||||
reply t ("376", ["End of /MOTD command"]);
|
||||
end
|
||||
|
||||
|
|
@ -382,7 +388,7 @@ let quit t me ~reason =
|
|||
|
||||
User.unregister me ~router:t.router;
|
||||
List.iter
|
||||
(part me ~router:t.router ~reason:None)
|
||||
(part t me ~reason:None)
|
||||
(User.channels me);
|
||||
|
||||
t.user <- None
|
||||
|
|
@ -414,10 +420,8 @@ let attempt_to_register t =
|
|||
User.register me ~router:t.router;
|
||||
t.user <- Some me;
|
||||
welcome t me;
|
||||
set_user_mode me {
|
||||
add = initial_user_mode;
|
||||
rem = Irc.Mode.Set.empty;
|
||||
};
|
||||
set_user_mode me
|
||||
~add:(Server_info.conf t.server_info).init_umode;
|
||||
Ok ()
|
||||
| _, _ ->
|
||||
Ok ()
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@ let join chan user =
|
|||
begin
|
||||
mem.mem_in_chan <- Some (Dllist.add_r mem chan.members);
|
||||
mem.mem_in_user <- Some (Dllist.add_r mem user.membership);
|
||||
(* TODO: return mem? *)
|
||||
end
|
||||
|
||||
let membership chan user =
|
||||
|
|
|
|||
|
|
@ -59,11 +59,17 @@ let writer (fd : fd) (obox : Irc.Msg.t Lwt_stream.t) : unit Lwt.t =
|
|||
| Unix.Unix_error (ECONNRESET, _, _) -> Lwt.return_unit
|
||||
| exn -> Lwt.fail exn)
|
||||
|
||||
let handle_client (router : Router.t) (conn_fd : fd) (conn_addr : sockaddr) =
|
||||
let handle_client
|
||||
(conn_fd : fd)
|
||||
(conn_addr : sockaddr)
|
||||
~(router : Router.t)
|
||||
~(server_info : Server_info.t)
|
||||
=
|
||||
info (fun m -> m "new connection %a" pp_sockaddr conn_addr);
|
||||
let conn : Connection.t =
|
||||
Connection.make
|
||||
~router
|
||||
~server_info
|
||||
~addr:conn_addr
|
||||
in
|
||||
let reader = Lwt_stream.iter (Connection.on_msg conn) (reader conn_fd) in
|
||||
|
|
@ -80,16 +86,24 @@ let handle_client (router : Router.t) (conn_fd : fd) (conn_addr : sockaddr) =
|
|||
type config = {
|
||||
port : int;
|
||||
tcp_listen_backlog : int;
|
||||
hostname : string;
|
||||
(* TODO: motd *)
|
||||
}
|
||||
|
||||
let run (cfg : config) : unit Lwt.t =
|
||||
let server_info =
|
||||
Server_info.make
|
||||
~hostname:cfg.hostname
|
||||
(* ~motd *)
|
||||
in
|
||||
|
||||
let router : Router.t =
|
||||
Router.make ()
|
||||
in
|
||||
|
||||
let on_con (fd, adr) =
|
||||
Lwt.on_failure
|
||||
(handle_client router fd adr)
|
||||
(handle_client fd adr ~router ~server_info)
|
||||
(fun exn ->
|
||||
error (fun m -> m "%a: %a" pp_sockaddr adr Fmt.exn exn))
|
||||
in
|
||||
|
|
|
|||
|
|
@ -0,0 +1,56 @@
|
|||
type t = {
|
||||
hostname : string;
|
||||
created : string;
|
||||
motd : string list;
|
||||
conf : conf;
|
||||
}
|
||||
|
||||
and conf = {
|
||||
isupport : string list;
|
||||
all_umodes : Irc.Mode.user list;
|
||||
all_cmodes : Irc.Mode.chan_d list;
|
||||
all_pmodes : [Irc.Mode.chan_a | Irc.Mode.chan_b | Irc.Mode.chan_c] list;
|
||||
init_umode : Irc.Mode.Set.t;
|
||||
init_cmode : Irc.Mode.Set.t;
|
||||
}
|
||||
|
||||
let isupport = [
|
||||
"CASEMAPPING=ascii";
|
||||
"CHANTYPES=#";
|
||||
"CHANMODES=b,k,l,imstn";
|
||||
"PREFIX=(ov)@+";
|
||||
"are supported by this server";
|
||||
]
|
||||
|
||||
let default_conf = {
|
||||
isupport;
|
||||
all_umodes = [`i; `o; `w];
|
||||
all_cmodes = [`i; `m; `n; `s; `t];
|
||||
all_pmodes = [`b; `k; `l; `o; `v];
|
||||
init_umode = Irc.Mode.Set.of_list [`i; `w];
|
||||
init_cmode = Irc.Mode.Set.of_list [`n; `s; `t];
|
||||
}
|
||||
|
||||
let make ~hostname = {
|
||||
hostname;
|
||||
created =
|
||||
(* TODO: stringify timestamp *)
|
||||
"Sun Jan 7 09:58:24 PM EST 2024";
|
||||
motd = [
|
||||
(* TODO: load from file *)
|
||||
"MEOW MEOW MEOW MEOW MEOW";
|
||||
"meow meow meow meow meow";
|
||||
"meowmeowmeowmeowmeowmeow";
|
||||
];
|
||||
conf = default_conf;
|
||||
}
|
||||
|
||||
let version (_ : t) =
|
||||
(* TODO: generate version string at build time? *)
|
||||
"0.0.0"
|
||||
|
||||
let hostname t = t.hostname
|
||||
let prefix t = Irc.Msg.Server_prefix t.hostname
|
||||
let created t = t.created
|
||||
let motd t = t.motd
|
||||
let conf t = t.conf
|
||||
Loading…
Reference in New Issue