implement "MODE <user>" functionality, refactor welcome message

lib/server/connection.ml

@@ -32,7 +32,7 @@ let shutdown ?reason t =
   Outbox.close t.outbox
 
 
-(* TODO: configure these *)
+(* 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"
@@ -47,6 +47,8 @@ let srv_motd_lines = [
 
 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
@@ -56,29 +58,7 @@ let reply t (num, params) =
   Outbox.send t.outbox
     (Irc.Msg.make ~prefix num (target :: params))
 
-let welcome t me =
+let tryagain cmd          = "263", [cmd; "Please wait a while and try again."]
-  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)"]
@@ -95,12 +75,13 @@ let alreadyregistered     = "462", ["Unauthorized command (already registered)"]
 
 (* user registration *)
 
-let require_registered t =
+let require_registered t : User.t result =
   match t.user with
   | Some me -> Ok me
   | None -> Error notregistered
 
-let attempt_to_register t =
+let attempt_to_register ~welcome t =
+  (* [welcome : t -> user -> unit result] is defined near the bottom of this file *)
   match t.pending_nick, t.pending_userinfo with
   | Some nick, Some userinfo ->
     t.pending_nick <- None;
@@ -109,17 +90,12 @@ let attempt_to_register t =
       | `nick_in_use -> Error (nicknameinuse nick)
       | `nick_set ->
         t.user <- Some me;
-        welcome t 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 on_msg_nick ~welcome t nick =
   let* () =
     match Irc.name_type nick with
     | `nick -> Ok ()
@@ -139,9 +115,9 @@ let on_msg_nick t nick =
     end
   | None ->
     t.pending_nick <- Some nick;
-    attempt_to_register t
+    attempt_to_register t ~welcome
 
-let on_msg_user t username realname =
+let on_msg_user ~welcome t username realname =
   match t.user with
   | Some _me -> Error alreadyregistered
   | None ->
@@ -151,7 +127,7 @@ let on_msg_user t username realname =
       | ADDR_UNIX path    -> path
     in
     t.pending_userinfo <- Some { username; realname; hostname };
-    attempt_to_register t
+    attempt_to_register t ~welcome
 
 
 (* messages and channels *)
@@ -230,7 +206,7 @@ let on_msg_part t name =
     try
       match Irc.name_type name with
       | `chan -> Ok (Router.find_chan t.router name)
-      | `nick | `invalid -> Error (nosuchchannel name)
+      | `nick | `invalid -> raise Not_found
     with Not_found ->
       Error (nosuchchannel name)
   in
@@ -246,8 +222,80 @@ let on_msg_part t name =
   Ok ()
 
 
+(* modes *)
+
+let user_get_mode user me =
+  let modestr = Fmt.str "+%a" Irc.Mode.Set.pp (User.mode user) in
+  let msg = Irc.Msg.make "MODE" [User.nick user; modestr] in
+  Router.relay msg ~from:me `to_self;
+  Ok ()
+
+let user_set_mode user me modestr args =
+  let _ = me, user, modestr, args in
+  (* TODO *)
+  Error (tryagain "MODE")
+
+let chan_get_mode chan me =
+  let _ = me, chan in
+  (* TODO *)
+  Error (tryagain "MODE")
+
+let chan_set_mode chan me modestr args =
+  let _ = me, chan, modestr, args in
+  (* TODO *)
+  Error (tryagain "MODE")
+
+let on_msg_mode t name args =
+  let* me = require_registered t in
+  let* set, get =
+    try
+      match Irc.name_type name with
+      | `nick ->
+        let u = Router.find_user t.router name in
+        Ok (user_set_mode u, user_get_mode u)
+      | `chan ->
+        let c = Router.find_chan t.router name in
+        Ok (chan_set_mode c, chan_get_mode c)
+      | `invalid -> raise Not_found
+    with Not_found ->
+      Error (nosuchnick name)
+  in
+  match args with
+  | [] -> get me
+  | modestr :: args -> set me modestr args
+
+
 (* misc *)
 
+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 =
+  about t me;
+  motd t;
+  user_get_mode me me
+
+let on_msg_nick = on_msg_nick ~welcome
+let on_msg_user = on_msg_user ~welcome
+
 let on_msg_motd t =
   let* _me = require_registered t in
   motd t;
@@ -276,7 +324,8 @@ let dispatch t = function
   | "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, _ ->
+  | "MODE", tgt :: args when tgt <> "" -> on_msg_mode t tgt args
+  | ("USER" | "JOIN" | "NAMES" | "PART" | "MODE") as cmd, _ ->
     Error (needmoreparams cmd)
   | cmd, _ ->
     Error (unknowncommand cmd)