use result monad for Connection
This commit is contained in:
parent
4e3a86d21a
commit
f47a383fa1
|
|
@ -1,4 +1,5 @@
|
|||
open! Import
|
||||
open Result_syntax
|
||||
module User = Router.User
|
||||
module Chan = Router.Chan
|
||||
|
||||
|
|
@ -23,179 +24,11 @@ let shutdown ?reason t =
|
|||
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
|
||||
|
||||
(* > user registration *)
|
||||
|
||||
let require_registered t f =
|
||||
match t.user with
|
||||
| Some me -> f me
|
||||
| None -> `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 -> `nicknameinuse nick
|
||||
| `nick_set ->
|
||||
t.user <- Some me;
|
||||
|
||||
(* TODO: this sucks, fix it *)
|
||||
let mode_msg = Irc.Msg.make "MODE" [nick; "+iw"] in
|
||||
defer (fun () -> Router.relay mode_msg ~from:me `to_self);
|
||||
|
||||
`welcome me
|
||||
end
|
||||
| _, _ -> `ok
|
||||
|
||||
let on_msg_nick t nick =
|
||||
if Irc.name_type nick <> `nick then
|
||||
(if nick = "" then `nonicknamegiven else `erroneusnickname nick)
|
||||
else 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 -> `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 -> `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 me =
|
||||
(* TODO: comma-separated list of targets *)
|
||||
let msg = Irc.Msg.make "PRIVMSG" [tgt; txt] ~always_trailing:true in
|
||||
let dst =
|
||||
try
|
||||
match Irc.name_type tgt with
|
||||
| `chan -> `to_chan (Router.find_chan t.router tgt)
|
||||
| `nick -> `to_user (Router.find_user t.router tgt)
|
||||
| `invalid -> `not_found
|
||||
with Not_found -> `not_found
|
||||
in
|
||||
match dst with
|
||||
| `not_found -> `nosuchnick tgt
|
||||
| (`to_user _ | `to_chan _) as dst ->
|
||||
(* 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> *)
|
||||
Router.relay msg ~from:me dst;
|
||||
`ok
|
||||
|
||||
let list_names chan =
|
||||
let names =
|
||||
List.map
|
||||
(fun u -> "", User.nick u)
|
||||
(Chan.members chan)
|
||||
in
|
||||
`names ("@", Chan.name chan, names)
|
||||
|
||||
let on_msg_names t name _me =
|
||||
(* TODO: comma-separated list of channels *)
|
||||
match Irc.name_type name with
|
||||
| `nick | `invalid ->
|
||||
if name = "" then `needmoreparams else `nosuchchannel name
|
||||
| `chan ->
|
||||
let chan = try Some (Router.find_chan t.router name)
|
||||
with Not_found -> None
|
||||
in
|
||||
(* TODO: check if channel is +s and user is not a member *)
|
||||
(* TODO: check if user in channel is +i and user is not a member *)
|
||||
match chan with
|
||||
| None -> `nosuchchannel name
|
||||
| Some chan -> list_names chan
|
||||
|
||||
let on_msg_join t name me =
|
||||
(* TODO: comma-separated list of channels *)
|
||||
(* TODO: "0" parameter means part from all channels *)
|
||||
match Irc.name_type name with
|
||||
| `nick | `invalid ->
|
||||
if name = "" then `needmoreparams else `nosuchchannel name
|
||||
| `chan ->
|
||||
let chan = try Router.find_chan t.router name
|
||||
with Not_found ->
|
||||
Logs.debug (fun m -> m "making new channel %S" name);
|
||||
let chan = Chan.make ~name in
|
||||
(* TODO: make user +o *)
|
||||
Chan.register chan ~router:t.router;
|
||||
chan
|
||||
in
|
||||
if Chan.is_member chan me then
|
||||
`ok
|
||||
else begin
|
||||
(* TODO: check if channel is +k, get associated key from parameters *)
|
||||
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);
|
||||
list_names chan
|
||||
end
|
||||
|
||||
let on_msg_part t name me =
|
||||
(* TODO: comma-separated list of channels *)
|
||||
(* TODO: part reason *)
|
||||
match Irc.name_type name with
|
||||
| `nick | `invalid ->
|
||||
if name = "" then `needmoreparams else `nosuchchannel name
|
||||
| `chan ->
|
||||
let chan = try Some (Router.find_chan t.router name)
|
||||
with Not_found -> None
|
||||
in
|
||||
(* TODO: check if allowed to list names *)
|
||||
match chan with
|
||||
| None -> `nosuchchannel name
|
||||
| Some chan ->
|
||||
if not (Chan.is_member chan me) then `notonchannel name
|
||||
else begin
|
||||
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
|
||||
Chan.unregister chan ~router:t.router;
|
||||
`ok
|
||||
end
|
||||
|
||||
let on_msg_privmsg t tgt msg = require_registered t (on_msg_privmsg t tgt msg)
|
||||
let on_msg_names t name = require_registered t (on_msg_names t name)
|
||||
let on_msg_join t name = require_registered t (on_msg_join t name)
|
||||
let on_msg_part t name = require_registered t (on_msg_part t name)
|
||||
|
||||
(* > misc *)
|
||||
|
||||
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 sending *)
|
||||
|
||||
(* TODO: configure these *)
|
||||
let srv_host = "irc.tali.software"
|
||||
|
|
@ -207,57 +40,227 @@ let srv_motd_lines = [
|
|||
"meowmeowmeowmeowmeowmeow";
|
||||
]
|
||||
|
||||
let rpl t cmd params =
|
||||
|
||||
(* 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 cmd (target :: params))
|
||||
Outbox.send t.outbox
|
||||
(Irc.Msg.make ~prefix num (target :: params))
|
||||
|
||||
let rpl_tryagain t cmd = rpl t "263" [cmd; "Please wait a while and try again."]
|
||||
|
||||
let rpl_welcome t me =
|
||||
let isupport = [
|
||||
"CASEMAPPING=ascii";
|
||||
"CHANTYPES=#";
|
||||
"CHANMODES=b,k,l,imstn";
|
||||
"PREFIX=(ov)@+";
|
||||
] in
|
||||
let welcome t me =
|
||||
begin
|
||||
rpl t "001" ["Welcome to the tali IRC network %s"
|
||||
^ Irc.Msg.prefix_string (User.prefix me)];
|
||||
rpl t "002" [Fmt.str "Your host is %s, running version %s" srv_host srv_ver];
|
||||
rpl t "003" [Fmt.str "This server was created %s" srv_created];
|
||||
rpl t "004" [srv_host; srv_ver; "iow"; "imnst"; "bklov"];
|
||||
rpl t "005" (isupport @ ["are supported by this server"]);
|
||||
reply t ("001", ["Welcome to the tali IRC network %s" ^ Irc.Msg.prefix_string (User.prefix me)]);
|
||||
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 rpl_motd t =
|
||||
begin
|
||||
rpl t "375" [Fmt.str "- %s Message of the day - " srv_host];
|
||||
List.iter (fun ln -> rpl t "372" ["- " ^ ln]) srv_motd_lines;
|
||||
rpl t "376" ["End of /MOTD command"];
|
||||
end
|
||||
|
||||
let rpl_names t chan_prefix chan users =
|
||||
let motd t =
|
||||
begin
|
||||
List.iter (fun (up, u) -> rpl t "353" [chan_prefix; chan; up ^ u]) users;
|
||||
rpl t "366" [chan; "End of NAMES list"]
|
||||
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 err_nosuchnick t tgt = rpl t "401" [tgt; "No such nick/channel"]
|
||||
let err_nosuchchannel t tgt = rpl t "403" [tgt; "No such channel"]
|
||||
let err_norecipient t cmd = rpl t "411" [Fmt.str "No recipient given (%s)" cmd]
|
||||
let err_notexttosend t = rpl t "412" ["No text to send"]
|
||||
let err_unknowncommand t cmd = rpl t "421" [cmd; "Unknown command"]
|
||||
let err_nonicknamegiven t = rpl t "431" ["No nickname given"]
|
||||
let err_erroneousnickname t nick = rpl t "432" [nick; "Erroneus nickname"]
|
||||
let err_nicknameinuse t nick = rpl t "433" [nick; "Nickname is already in use"]
|
||||
let err_notonchannel t chan = rpl t "442" [chan; "You're not on that channel"]
|
||||
let err_notregistered t = rpl t "451" ["You have not registered"]
|
||||
let err_needmoreparams t cmd = rpl t "461" [cmd; "Not enough parameters"]
|
||||
let err_alreadyregistered t = rpl t "462" ["Unauthorized command (already registered)"]
|
||||
(* 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
|
||||
(* TODO: comma-separated list of targets *)
|
||||
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
|
||||
(* TODO: comma-separated list of channels *)
|
||||
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: comma-separated list of channels *)
|
||||
(* 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, get associated key from parameters *)
|
||||
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: comma-separated list of channels *)
|
||||
(* 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 *)
|
||||
|
||||
|
|
@ -265,37 +268,20 @@ let on_msg t (msg : Irc.Msg.t) : unit =
|
|||
(* Logs.debug (fun m -> m "%a: %a" pp_sockaddr t.addr Irc.Msg.pp msg); *)
|
||||
let result =
|
||||
match msg.command, msg.params with
|
||||
| "NICK", new_nick :: _ -> on_msg_nick t new_nick
|
||||
| "NICK", [] -> `nonicknamegiven
|
||||
| "NICK", nick :: _ when nick <> "" -> on_msg_nick t nick
|
||||
| "NICK", _ -> Error nonicknamegiven
|
||||
| "USER", unm :: _ :: _ :: rnm :: _ -> on_msg_user t unm rnm
|
||||
| "USER", _ -> `needmoreparams
|
||||
| "QUIT", why -> on_msg_quit t why
|
||||
| "MOTD", _ -> `motd
|
||||
| "MOTD", _ -> on_msg_motd t
|
||||
| "PRIVMSG", tgt :: msg :: _ -> on_msg_privmsg t tgt msg
|
||||
| "PRIVMSG", [_] -> `notexttosend | "PRIVMSG", [] -> `norecipient
|
||||
| "JOIN", tgt :: _ -> on_msg_join t tgt
|
||||
| "JOIN", _ -> `needmoreparams
|
||||
| "NAMES", tgt :: _ -> on_msg_names t tgt
|
||||
| "NAMES", _ -> `needmoreparams
|
||||
| "PART", tgt :: _ -> on_msg_part t tgt
|
||||
| "PART", _ -> `needmoreparams
|
||||
| _, _ -> `unknowncommand
|
||||
| "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", _ ->
|
||||
Error (needmoreparams msg.command)
|
||||
| _, _ -> Error (unknowncommand msg.command)
|
||||
in
|
||||
match result with
|
||||
| `ok -> ()
|
||||
| `welcome usr -> rpl_welcome t usr; rpl_motd t
|
||||
| `motd -> rpl_motd t
|
||||
| `names (cp, ch, us) -> rpl_names t cp ch us
|
||||
| `tryagain -> rpl_tryagain t msg.command
|
||||
| `alreadyregistered -> err_alreadyregistered t
|
||||
| `erroneusnickname n -> err_erroneousnickname t n
|
||||
| `needmoreparams -> err_needmoreparams t msg.command
|
||||
| `nicknameinuse n -> err_nicknameinuse t n
|
||||
| `nonicknamegiven -> err_nonicknamegiven t
|
||||
| `norecipient -> err_norecipient t msg.command
|
||||
| `nosuchchannel c -> err_nosuchchannel t c
|
||||
| `nosuchnick n -> err_nosuchnick t n
|
||||
| `notexttosend -> err_notexttosend t
|
||||
| `notonchannel c -> err_notonchannel t c
|
||||
| `notregistered -> err_notregistered t
|
||||
| `unknowncommand -> err_unknowncommand t msg.command
|
||||
| Ok () -> ()
|
||||
| Error err -> reply t err
|
||||
|
|
|
|||
|
|
@ -14,3 +14,8 @@ let empty_string_ci = Case_insensitive ""
|
|||
|
||||
let defer f =
|
||||
Lwt.on_success (Lwt.pause ()) f
|
||||
|
||||
module Result_syntax = struct
|
||||
let ( let* ) = Result.bind
|
||||
let ( let+ ) r f = Result.map f r
|
||||
end
|
||||
|
|
|
|||
Loading…
Reference in New Issue