yet another user register flow refactor

lib/irc/msg.ml

@@ -3,22 +3,13 @@ open Types
 type prefix =
   | No_prefix
   | Server_prefix of string
-  | User_prefix of name * userinfo option * string option
+  | User_prefix of name * userinfo option
-
-let pp_userinfo_opt ppf = function
-  | None -> ()
-  | Some { username; _ } -> Format.fprintf ppf "!%s" username
-
-let pp_hostname_opt ppf = function
-  | None -> ()
-  | Some hostname -> Format.fprintf ppf "@%s" hostname
 
 let prefix_string = function
   | No_prefix -> ""
-  | Server_prefix s -> s
+  | Server_prefix servername -> servername
-  | User_prefix (nick, uinfo, host) ->
+  | User_prefix (nick, None) -> nick
-    Format.asprintf "%s%a%a"
+  | User_prefix (nick, Some uinfo) -> Format.asprintf "%s%a" nick pp_userinfo uinfo
-      nick pp_userinfo_opt uinfo pp_hostname_opt host
 
 let pp_prefix ppf p =
   Format.fprintf ppf "%S" (prefix_string p)
@@ -158,14 +149,15 @@ let%expect_test _ =
   Format.printf "%a" pp_prefix (Server_prefix "localhost");
   [%expect {| "localhost" |}];
 
-  Format.printf "%a" pp_prefix (User_prefix ("tali", None, None));
+  Format.printf "%a" pp_prefix (User_prefix ("tali", None));
   [%expect {| "tali" |}];
 
-  Format.printf "%a" pp_prefix (User_prefix ("tali", None, Some "elsewhere"));
+  let milo = {
-  [%expect {| "tali@elsewhere" |}];
+    username = "milo";
-
+    realname = "Milo";
-  let milo = { username = "milo"; realname = "Milo" } in
+    hostname = "elsewhere";
-  Format.printf "%a" pp_prefix (User_prefix ("tali", Some milo, Some "elsewhere"));
+  } in
+  Format.printf "%a" pp_prefix (User_prefix ("tali", Some milo));
   [%expect {| "tali!milo@elsewhere" |}];
 
   make "NICK" ["tali"] |> print_msg_nl;

lib/irc/msg.mli

@@ -3,7 +3,7 @@ open Types
 type prefix =
   | No_prefix
   | Server_prefix of string
-  | User_prefix of name * userinfo option * string option
+  | User_prefix of name * userinfo option
 
 val prefix_string : prefix -> string
 

lib/irc/types.ml

@@ -1,5 +1,14 @@
 type name = string
-type userinfo = { username : string; realname : string }
+
+type userinfo = {
+  username : string;
+  realname : string;
+  hostname : string;
+}
+
+let pp_userinfo ppf { username; realname; hostname } =
+  ignore realname;
+  Format.fprintf ppf "!%s@%s" username hostname
 
 let name_type s =
   let rec valid i =

lib/server/connection.ml

@@ -3,91 +3,89 @@ module User = Router.User
 module Chan = Router.Chan
 
 type t = {
-  addr : sockaddr;
   router : Router.t;
-  user : User.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 hostname = match addr with
-    | ADDR_INET (ia, _) -> Unix.string_of_inet_addr ia
-    | ADDR_UNIX path -> path
-  in
   let outbox = Outbox.make () in
-  let user = User.make ~hostname ~outbox in
+  { router; addr; outbox; user = None; pending_nick = None; pending_userinfo = None }
-  { addr; router; user; outbox; pending_nick = None }
 
 let outbox t = t.outbox
 
 let shutdown ?reason t =
-  if User.is_registered t.user then begin
+  Option.iter
-    (* TODO: relay to everyone interested *)
+    (fun me ->
-    let reason = Option.value reason ~default:"Goot bye" in
+       let reason = Option.value reason ~default:"Goot bye" in
-    Router.relay (Irc.Msg.make "QUIT" [reason])
+       Router.relay (Irc.Msg.make "QUIT" [reason]) ~from:me (`to_interested me);
-      ~from:t.user (`to_interested t.user);
+       User.part_all me;
-    User.part_all t.user;
+       User.unregister me ~router:t.router)
-    User.unregister t.user ~router:t.router;
+    t.user;
-  end;
   Outbox.close t.outbox
 
-(* message handling *)
-
-let require_registered t f =
-  if User.is_registered t.user then
-    f (Option.get t.user.userinfo)
-  else
-    `notregistered
-
 (* > 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.user.userinfo with
+  match t.pending_nick, t.pending_userinfo with
-  | Some nick, Some _userinfo ->
+  | Some nick, Some userinfo ->
     t.pending_nick <- None;
-    begin match User.set_nick t.user nick ~router:t.router with
+    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:t.user `to_self);
+        defer (fun () -> Router.relay mode_msg ~from:me `to_self);
 
-        `welcome
+        `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 if User.is_registered t.user then
+  else match t.user with
-    let success_callback () =
+    | Some me ->
-      let msg = Irc.Msg.make "NICK" [nick] in
+      begin
-      Router.relay msg ~from:t.user (`to_interested t.user);
+        let msg = Irc.Msg.make "NICK" [nick] in
-    in
+        match
-    match User.set_nick t.user nick ~router:t.router ~success_callback with
+          User.set_nick me nick
-    | `nick_in_use -> `nicknameinuse nick
+            ~router:t.router
-    | `nick_set -> `ok
+            ~success_callback:(fun () -> Router.relay msg ~from:me (`to_interested me))
-  else begin
+        with
-    t.pending_nick <- Some nick;
+        | `nick_in_use -> `nicknameinuse nick
-    attempt_to_register t
+        | `nick_set -> `ok
-  end
+      end
+    | None ->
+      t.pending_nick <- Some nick;
+      attempt_to_register t
 
-let on_msg_user t username modestr realname =
+let on_msg_user t username realname =
-  if User.is_registered t.user then
+  match t.user with
-    `alreadyregistered
+  | Some _me -> `alreadyregistered
-  else begin
+  | None ->
-    (* NB: "+iw" is automatically set, so it's impossible to actually affect the initial
+    (* TODO: configure hiding hostnames *)
-       mode with the parameter to USER *)
+    let hostname = match t.addr with
-    ignore modestr;
+      | ADDR_INET (ia, _) -> Unix.string_of_inet_addr ia
-    t.user.userinfo <- Some { username; realname };
+      | ADDR_UNIX path -> path
+    in
+    t.pending_userinfo <- Some { username; realname; hostname };
     attempt_to_register t
-  end
 
 (* > messages and channels *)
 
-let on_msg_privmsg t tgt txt _ =
+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 =
@@ -105,7 +103,7 @@ let on_msg_privmsg t tgt txt _ =
     (* 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:t.user dst;
+    Router.relay msg ~from:me dst;
     `ok
 
 let list_names chan =
@@ -116,7 +114,7 @@ let list_names chan =
   in
   `names ("@", Chan.name chan, names)
 
-let on_msg_names t name _ =
+let on_msg_names t name _me =
   (* TODO: comma-separated list of channels *)
   match Irc.name_type name with
   | `nick | `invalid ->
@@ -131,7 +129,7 @@ let on_msg_names t name _ =
     | None -> `nosuchchannel name
     | Some chan -> list_names chan
 
-let on_msg_join t name _ =
+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
@@ -146,18 +144,18 @@ let on_msg_join t name _ =
         Chan.register chan ~router:t.router;
         chan
     in
-    if Chan.is_member chan t.user then
+    if Chan.is_member chan me then
       `ok
     else begin
       (* TODO: check if channel is +k, get associated key from parameters *)
-      Chan.join chan t.user;
+      Chan.join chan me;
       let msg = Irc.Msg.make "JOIN" [name] in
-      Router.relay msg ~from:t.user `to_self;
+      Router.relay msg ~from:me `to_self;
-      Router.relay msg ~from:t.user (`to_chan chan);
+      Router.relay msg ~from:me (`to_chan chan);
       list_names chan
     end
 
-let on_msg_part t name _ =
+let on_msg_part t name me =
   (* TODO: comma-separated list of channels *)
   (* TODO: part reason *)
   match Irc.name_type name with
@@ -171,12 +169,12 @@ let on_msg_part t name _ =
     match chan with
     | None -> `nosuchchannel name
     | Some chan ->
-      if not (Chan.is_member chan t.user) then `notonchannel name
+      if not (Chan.is_member chan me) then `notonchannel name
       else begin
         let msg = Irc.Msg.make "PART" [name] in
-        Router.relay msg ~from:t.user `to_self;
+        Router.relay msg ~from:me `to_self;
-        Router.relay msg ~from:t.user (`to_chan chan);
+        Router.relay msg ~from:me (`to_chan chan);
-        Chan.part chan t.user;
+        Chan.part chan me;
         if Chan.no_members chan then
           Chan.unregister chan ~router:t.router;
         `ok
@@ -211,13 +209,15 @@ let srv_motd_lines = [
 
 let rpl t cmd params =
   let prefix = Irc.Msg.Server_prefix srv_host in
-  let target = User.nick t.user 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))
 
 let rpl_tryagain t cmd = rpl t "263" [cmd; "Please wait a while and try again."]
 
-let rpl_welcome t =
+let rpl_welcome t me =
-  let who = Irc.Msg.prefix_string (User.prefix t.user) in
   let isupport = [
     "CASEMAPPING=ascii";
     "CHANTYPES=#";
@@ -225,7 +225,8 @@ let rpl_welcome t =
     "PREFIX=(ov)@+";
   ] in
   begin
-    rpl t "001" [Fmt.str "Welcome to the tali IRC network %s" who];
+    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"];
@@ -266,7 +267,7 @@ let on_msg t (msg : Irc.Msg.t) : unit =
     match msg.command, msg.params with
     | "NICK", new_nick :: _ -> on_msg_nick t new_nick
     | "NICK", [] -> `nonicknamegiven
-    | "USER", u :: m :: _h :: r :: _ -> on_msg_user t u m r
+    | "USER", unm :: _ :: _ :: rnm :: _ -> on_msg_user t unm rnm
     | "USER", _ -> `needmoreparams
     | "QUIT", why -> on_msg_quit t why
     | "MOTD", _ -> `motd
@@ -282,7 +283,7 @@ let on_msg t (msg : Irc.Msg.t) : unit =
   in
   match result with
   | `ok -> ()
-  | `welcome -> rpl_welcome t; rpl_motd t
+  | `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

lib/server/router.ml

@@ -7,10 +7,9 @@ type t = {
 
 and user = {
   outbox : Outbox.t;
-  hostname : string;
+  userinfo : Irc.userinfo;
   mutable nick : Irc.name;
   mutable nick_key : string_ci;
-  mutable userinfo : Irc.userinfo option;
   mutable membership : membership Dllist.t;
 }
 
@@ -40,11 +39,11 @@ let find_user t nick =
 let find_chan t name =
   Hashtbl.find t.channels (string_ci name)
 
-let user_prefix u =
+let user_prefix user =
-  Irc.Msg.User_prefix (u.nick, u.userinfo, Some u.hostname)
+  Irc.Msg.User_prefix (user.nick, Some user.userinfo)  
 
-let relay ~from msg target =
+let relay ~(from : user) (msg : Irc.Msg.t) target =
-  let msg = { msg with Irc.Msg.prefix = user_prefix from } in
+  let msg = { msg with prefix = user_prefix from } in
   match target with
   | `to_self ->
     Outbox.send from.outbox msg
@@ -68,13 +67,12 @@ let relay ~from msg target =
 module User = struct
   type t = user
 
-  let make ~hostname ~outbox =
+  let make ~userinfo ~outbox =
     {
-      hostname;
       outbox;
+      userinfo;
       nick = "*";
       nick_key = empty_string_ci;
-      userinfo = None;
       (* mode = "+iw"; *)
       membership = Dllist.create ();
     }
@@ -82,7 +80,7 @@ module User = struct
   let outbox t = t.outbox
   let nick t = t.nick
   let prefix = user_prefix
-  let is_registered t = t.nick_key <> empty_string_ci
+  (* let is_registered t = t.nick_key <> empty_string_ci *)
 
   let unregister t ~router =
     Hashtbl.remove router.users t.nick_key;