working on routing

lib/server/connection.ml

@@ -2,93 +2,166 @@ open! Import
 
 type t = {
   addr : sockaddr;
-  userbase : Userbase.t;
+  user : Router.user;
-  user : Userbase.user;
-  mutable regis : string option * (string * string) option;
   outbox : Irc.Msg.t Lwt_stream.t;
   push_outbox : (Irc.Msg.t option -> unit);
   quit : unit Lwt_condition.t;
 }
 
-let make ~(userbase : Userbase.t) ~(addr : sockaddr) : t =
+let make ~(router : Router.t) ~(addr : sockaddr) : t =
-  let user = Userbase.make_user () in
+  let hostname = match addr with
-  let regis = None, None in
+    | ADDR_INET (ia, _) -> Unix.string_of_inet_addr ia
+    | ADDR_UNIX path -> path
+  in
+  let user = Router.User.make router ~hostname in
   let outbox, push_outbox = Lwt_stream.create () in
-  let quit = Lwt_condition.create () in
+  {
-  { addr; userbase; user; regis; outbox; push_outbox; quit }
+    addr; user; outbox; push_outbox;
+    quit = Lwt_condition.create ();
+  }
 
 let quitting t = Lwt_condition.wait t.quit
 let outbox t = t.outbox
-let send t msg = t.push_outbox (Some msg)
+let send t msg = try t.push_outbox (Some msg) with Lwt_stream.Closed -> ()
 
 let cleanup t =
-  Userbase.leave t.userbase t.user
+  t.push_outbox None;
+  Router.User.cleanup t.user
 
-(* message handlers *)
+(* message handling *)
+
+let require_registered t f =
+  if Router.User.is_registered t.user then
+    f (Option.get t.user.userinfo)
+  else
+    `notregistered
 
 (* > user registration *)
 
-let update_regis t nick username =
+let attempt_to_register t =
-  t.regis <- (nick, username);
+  match t.user.nick, t.user.userinfo with
-  match nick, username with
+  | Some nick, Some _userinfo ->
-  | Some nick, Some _ ->
+    begin match Router.User.set_nick t.user nick with
-    begin match Userbase.register t.userbase ~nick ~user:t.user with
+      | `nick_in_use -> `nicknameinuse nick
-      | `inuse -> `nicknameinuse nick
+      | `nick_set ->
-      | `ok -> `ok
+        Logs.debug (fun m -> m "init mode: +%a" Irc.Mode.pp t.user.mode);
+        (* TODO: set initial mode *)
+        `welcome
     end
-  | _, _ ->
+  | _, _ -> `ok
-    (* wait for remaining credentials *)
-    `ok
 
-let on_nick_msg t new_nick =
+let on_msg_nick t nick =
-  (* TODO: validate nickname string *)
+  if Router.User.is_registered t.user then
-  let _, username = t.regis in
+    match Router.User.set_nick t.user nick with
-  update_regis t (Some new_nick) username
+    | `nick_in_use -> `nicknameinuse nick
+    | `nick_set -> `ok
+  else begin
+    t.user.nick <- Some nick;
+    attempt_to_register t
+  end
 
-let on_user_msg t new_username _mode =
+let on_msg_user t username modestr realname =
-  (* TODO: validate user string *)
+  if Router.User.is_registered t.user then
-  (* TODO: validate mode string *)
-  match t.regis with
-  | nick, None ->
-    update_regis t nick (Some new_username)
-  | _, Some _ ->
     `alreadyregistered
+  else begin
+    (* NB: +iw is automatically set, so it's impossible to actually affect the initial
+       mode with the parameter to USER *)
+    ignore modestr;
+    t.user.userinfo <- Some { username; realname };
+    attempt_to_register t
+  end
 
+(* > messages and channels *)
+
+let on_msg_privmsg t tgt msg _userinfo =
+  match Router.find_user t.user.router tgt with
+  | None -> `nosuchnick tgt
+  | Some _ ->
+    let _ = msg in
+    (* TODO: send messages *)
+    `tryagain
+
+let on_msg_privmsg t tgt msg = require_registered t (on_msg_privmsg t tgt msg)
+    
 (* > misc *)
 
-let on_quit_msg t why =
+let on_msg_quit t why =
-  Logs.debug (fun m -> m "%a: quit: %S" pp_sockaddr t.addr (String.concat " " why));
+  let why = String.concat " " why in
+  Logs.debug (fun m -> m "%a: quit: %S" pp_sockaddr t.addr why);
   Lwt_condition.broadcast t.quit ();
   `ok
 
-(* message transmission *)
+(* message sending *)
 
-module Rpl = struct
+(* TODO: configure these *)
-  open Irc.Msg
+let srv_host = "irc.tali.software"
-  let unknowncommand cmd = make "421" [cmd; "Unknown command"]
+let srv_ver = "0.0.0"
-  let needmoreparams cmd = make "461" [cmd; "Not enough parameters"]
+let srv_created = "Sun Jan 7 09:58:24 PM EST 2024"
-  let tryagain cmd = make "263" [cmd; "Please wait a while and try again."]
+let srv_motd_lines = [
-  let alreadyregistered () = make "462" ["Unauthorized command (already registered)"]
+  "MEOW MEOW MEOW MEOW MEOW";
-  let nicknameinuse nick = make "433" [nick; "Nickname is already in use"]
+  "meow meow meow meow meow";
-end
+  "meowmeowmeowmeowmeowmeow";
+]
+
+let rpl t cmd params =
+  let prefix = Irc.Msg.Server_prefix srv_host in
+  let target = Router.User.nick t.user in
+  send t (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 who = Irc.Msg.prefix_string (Router.User.prefix t.user) in
+  begin
+    rpl t "001" [Fmt.str "Welcome to the tali IRC network %s" who];
+    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; "aiwroOs"; "oinvm"];
+  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 err_alreadyregistered t = rpl t "462" ["Unauthorized command (already registered)"]
+let err_needmoreparams t cmd = rpl t "461" [cmd; "Not enough parameters"]
+let err_nicknameinuse t nick = rpl t "433" [nick; "Nickname is already in use"]
+let err_norecipient t cmd = rpl t "411" [Fmt.str "No recipient given (%s)" cmd]
+let err_nosuchnick t tgt = rpl t "401" [tgt; "No such nick/channel"]
+let err_notexttosend t = rpl t "412" [Fmt.str "No text to send"]
+let err_notregistered t = rpl t "451" ["You have not registered"]
+let err_unknowncommand t cmd = rpl t "421" [cmd; "Unknown command"]
+
+(* message parsing *)
 
 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_nick_msg t new_nick
+      on_msg_nick t new_nick
-    | "USER", uname :: modestr :: _host :: rname :: _ ->
+    | "USER", username :: modestr :: _host :: realname :: _ ->
-      on_user_msg t (uname, rname) modestr
+      on_msg_user t username modestr realname
     | "QUIT", why ->
-      on_quit_msg t why
+      on_msg_quit t why
+    | "PRIVMSG", tgt :: msg :: _ ->
+      on_msg_privmsg t tgt msg
+    | "PRIVMSG", [_] -> `notexttosend | "PRIVMSG", [] -> `norecipient
     | "NICK", _ | "USER", _ -> `needmoreparams
     | _, _ -> `unknowncommand
   in
   match result with
   | `ok -> ()
-  | `unknowncommand -> send t (Rpl.unknowncommand msg.command)
+  | `welcome -> rpl_welcome t; rpl_motd t
-  | `needmoreparams -> send t (Rpl.needmoreparams msg.command)
+  | `tryagain -> rpl_tryagain t msg.command
-  | `tryagain -> send t (Rpl.tryagain msg.command)
+  | `alreadyregistered -> err_alreadyregistered t
-  | `alreadyregistered -> send t (Rpl.alreadyregistered ())
+  | `needmoreparams -> err_needmoreparams t msg.command
-  | `nicknameinuse n -> send t (Rpl.nicknameinuse n)
+  | `nicknameinuse n -> err_nicknameinuse t n    
+  | `norecipient -> err_norecipient t msg.command
+  | `nosuchnick n -> err_nosuchnick t n
+  | `notexttosend -> err_notexttosend t
+  | `notregistered -> err_notregistered t
+  | `unknowncommand -> err_unknowncommand t msg.command

lib/server/irc_server.ml

@@ -55,11 +55,11 @@ 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 cx (conn_fd : fd) (conn_addr : sockaddr) =
+let handle_client (router : Router.t) (conn_fd : fd) (conn_addr : sockaddr) =
   let conn : Connection.t =
     Connection.make
+      ~router
       ~addr:conn_addr
-      ~userbase:cx#get_userbase
   in
   let rd = Lwt_stream.iter (Connection.on_msg conn) (reader conn_fd) in
   let wr = writer conn_fd (Connection.outbox conn) in
@@ -79,14 +79,13 @@ type config = {
 }
 
 let run (cfg : config) : unit Lwt.t =
-  let cx = object
+  let router : Router.t =
-    val userbase = Userbase.make ()
+    Router.make ()
-    method get_userbase = userbase
+  in
-  end in
 
   let on_con (fd, adr) =
     Lwt.on_failure
-      (handle_client cx fd adr)
+      (handle_client router fd adr)
       (fun exn ->
          Logs.err (fun m -> m "%a: %a" pp_sockaddr adr Fmt.exn exn))
   in

lib/server/router.ml

@@ -0,0 +1,75 @@
+type nick_key = Nick_key of string [@@unboxed]
+let nick_key n = Nick_key (String.lowercase_ascii n) (* TODO: "scandinavian" lowercase *)
+let unset = Nick_key ""
+
+(* TODO: notifications *)
+(* type notif = *)
+(*   | Mode of Irc.nick * Irc.nick * Irc.Mode.t *)
+(*   | Nick of Irc.Msg.prefix * Irc.nick *)
+
+type t = {
+  users : (nick_key, user) Hashtbl.t
+  (* TODO: channels *)
+}
+
+and user = {
+  router : t;
+  hostname : string;
+  mutable key : nick_key;
+  mutable nick : Irc.nick option;
+  mutable userinfo : Irc.userinfo option;
+  mutable mode : Irc.Mode.t;
+  (* inbox : notif Lwt_stream.t; *)
+  (* push_inbox : (notif option -> unit); *)
+}
+
+let make () =
+  { users = Hashtbl.create 4096 }
+
+let find_user t nick =
+  Hashtbl.find_opt t.users (nick_key nick)
+
+module User = struct
+  type t = user
+
+  let make router ~hostname =
+    (* let inbox, push_inbox = Lwt_stream.create () in *)
+    {
+      router;
+      hostname;
+      key = unset;
+      nick = None;
+      userinfo = None;
+      mode = Irc.Mode.of_string "iw";
+      (* inbox; push_inbox; *)
+    }
+
+  let nick t = Option.value t.nick ~default:"*"
+
+  let prefix t : Irc.Msg.prefix =
+    match t.nick with
+    | None -> No_prefix
+    | Some nick -> User_prefix (nick, t.userinfo, Some t.hostname)
+
+  let is_registered t = t.key <> unset
+
+  let unset_nick t =
+    Hashtbl.remove t.router.users t.key;
+    t.key <- unset
+
+  let set_nick t new_nick =
+    let key = nick_key new_nick in
+    if Hashtbl.mem t.router.users key then
+      `nick_in_use
+    else begin
+      ((* TODO: notify others of nick change *));
+      unset_nick t;
+      Hashtbl.add t.router.users key t;
+      t.key <- key;
+      `nick_set
+    end
+
+  let cleanup user =
+    unset_nick user
+    (* user.push_inbox None *)
+end

lib/server/userbase.ml

@@ -1,39 +0,0 @@
-type privmsg = {
-  pm_from : string;
-  pm_text : string;
-}
-
-type user = {
-  mutable nick : string option;
-  inbox : notif Lwt_stream.t;
-  push_inbox : (notif option -> unit);
-}
-
-and notif = privmsg
-
-let make_user () =
-  let inbox, push_inbox = Lwt_stream.create () in
-  { nick = None; inbox; push_inbox }
-
-let notify u no = u.push_inbox (Some no)
-
-type t = {
-  users : (string, user) Hashtbl.t
-  (* TODO: channels *)
-}
-
-let make () =
-  { users = Hashtbl.create 4096 }
-
-let register t ~nick ~user =
-  if Hashtbl.mem t.users nick then
-    `inuse
-  else begin
-    Option.iter (Hashtbl.remove t.users) user.nick;
-    Hashtbl.add t.users nick user;
-    user.nick <- Some nick;
-    `ok
-  end
-
-let leave t user =
-  Option.iter (Hashtbl.remove t.users) user.nick