implement WHOWAS using Cache to store history

bin/main.ml

@@ -4,8 +4,9 @@ Logging.init_pretty_writer stderr
 Lwt_main.run
   (Server.run {
       port = 6667;
-      tcp_listen_backlog = 8;
+      listen_backlog = 8;
       ping_interval = 60;
+      whowas_history_len = 1000;
       hostname = "irc.tali.software";
       (* TODO: motd *)
     })

lib/server/connection.ml

@@ -61,7 +61,7 @@ let reply t (num, params) =
     | None -> "*"
   in
   let always_trailing = match num with
-    | "301" | "311" | "312" | "319" | "332" | "353" -> true
+    | "301" | "311" | "312" | "314" | "319" | "332" | "353" -> true
     | _ -> false
   in
   Outbox.send t.outbox
@@ -634,6 +634,26 @@ let on_msg_whois t nick =
   list_whois t user;
   Ok ()
 
+let list_whowas t nick limit =
+  List.iter_up_to ~limit
+    (fun (nick, { username; hostname; realname }) ->
+       reply t ("314", [nick; username; hostname; "*"; realname]))
+    (Router.whowas t.router nick);
+  reply t ("369", [nick; "End of WHOWAS"])
+
+let on_msg_whowas t nick count =
+  let* _me = require_registered t in
+  let limit =
+    try
+      let n = Option.get (int_of_string_opt count) in
+      if n <= 0 then invalid_arg "count <= 0";
+      n
+    with Invalid_argument _ ->
+      max_int
+  in
+  list_whowas t nick limit;
+  Ok ()
+
 
 (* welcome and quit *)
 
@@ -834,8 +854,11 @@ let dispatch t = function
   | "AWAY", args -> on_msg_away t (concat_args args)
   | "MODE", tgt :: args when tgt <> "" -> on_msg_mode t tgt args
   | "WHO", mask :: _ when mask <> "" -> on_msg_who t mask
-  | "WHOIS", ([] | [""] | (_ :: "" :: _)) -> Error nonicknamegiven
+  | "WHOIS", ([] | [""] | _ :: "" :: _) -> Error nonicknamegiven
-  | "WHOIS", ([nick] | (_ :: nick :: _)) -> on_msg_whois t nick
+  | "WHOIS", ([nick] | _ :: nick :: _) -> on_msg_whois t nick
+  | "WHOWAS", ([] | "" :: _) -> Error nonicknamegiven
+  | "WHOWAS", [nick] -> on_msg_whowas t nick ""
+  | "WHOWAS", nick :: count :: _ -> on_msg_whowas t nick count
   | ("USER" | "JOIN" | "NAMES" | "PART" | "KICK" | "MODE" | "WHO") as cmd, _ ->
     Error (needmoreparams cmd)
   (* TODO: "LIST" *)
@@ -847,7 +870,6 @@ let dispatch t = function
   (* TODO: "HELP" *)
   (* TODO: "INFO" *)
   (* TODO: "NOTICE" *)
-  (* TODO: "WHOWAS" *)
   (* TODO: "KILL" *)
   (* TODO: "REHASH" *)
   (* TODO: "RESTART" *)

lib/server/router.ml

@@ -5,9 +5,11 @@ include (val Logging.sublogs logger "Router")
 
 type t = router
 
-let make () =
+let make ~whowas_history_len = {
-  { users = Hashtbl.create 4096;
+  users = Hashtbl.create 1024;
-    channels = Hashtbl.create 4096 }
+  channels = Hashtbl.create 1024;
+  whowas = Cache.make whowas_history_len;
+}
 
 let is_nick_available t nick =
   not (Hashtbl.mem t.users (string_ci nick))
@@ -18,6 +20,9 @@ let find_user t nick =
 let find_chan t name =
   Hashtbl.find t.channels (string_ci name)
 
+let whowas t nick =
+  Cache.find_all t.whowas (string_ci nick)
+
 let relay ~(from : user) (msg : Msg.t) tgts =
   let msg =
     if msg.prefix = No_prefix then

lib/server/router_types.ml

@@ -42,4 +42,5 @@ and priv =
 type router = {
   users : (string_ci, user) Hashtbl.t;
   channels : (string_ci, chan) Hashtbl.t;
+  whowas : (string_ci, name * userinfo) Cache.t;
 }

lib/server/server.ml

@@ -6,14 +6,14 @@ include (val Logging.sublogs logger "Server")
 
 type ping_wheel = Connection.t Wheel.t
 
-let listener ~(port : int) ~(backlog : int) : (fd * sockaddr) Lwt_stream.t =
+let listener ~(port : int) ~(listen_backlog : int) : (fd * sockaddr) Lwt_stream.t =
   let sock : fd Lwt.t =
     let fd = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
     Lwt_unix.setsockopt fd SO_KEEPALIVE false;
     Lwt_unix.setsockopt fd SO_REUSEPORT true;
     let srv_adr = Unix.ADDR_INET (Unix.inet_addr_any, port) in
     let* () = Lwt_unix.bind fd srv_adr in
-    Lwt_unix.listen fd backlog;
+    Lwt_unix.listen fd listen_backlog;
     info (fun m -> m "listening on %a" pp_sockaddr srv_adr);
     Lwt.return fd
   in
@@ -94,26 +94,30 @@ let handle_client
 
 type config = {
   port : int;
-  tcp_listen_backlog : int;
+  listen_backlog : int;
   ping_interval : int;
+  whowas_history_len : int;
   hostname : string;
   (* TODO: motd *)
 }
 
-let run (cfg : config) : unit Lwt.t =
+let run { port; listen_backlog; ping_interval;
+          whowas_history_len; hostname } : unit Lwt.t
+  =
   let server_info =
     Server_info.make
-      ~hostname:cfg.hostname
+      ~hostname
       (* ~motd *)
   in
 
   let router : Router.t =
-    Router.make ()
+    Router.make
+      ~whowas_history_len
   in
 
   let ping_wheel : _ Wheel.t =
     Wheel.make
-      cfg.ping_interval
+      ping_interval
   in
 
   let on_tick () =
@@ -145,8 +149,8 @@ let run (cfg : config) : unit Lwt.t =
     Lwt_stream.iter
       on_con
       (listener
-         ~port:cfg.port
+         ~port
-         ~backlog:cfg.tcp_listen_backlog)
+         ~listen_backlog)
   in
 
   listener_promise <&> pinger_promise

lib/server/test_router.ml

@@ -9,7 +9,7 @@ let%expect_test _ =
     with e -> print_endline (Printexc.to_string e)
   in
 
-  let router = Router.make () in
+  let router = Router.make ~whowas_history_len:1000 in
 
   let u1 =
     User.make "beenie"

lib/server/user.ml

@@ -27,7 +27,12 @@ let set_nick t new_nick =
     t.nick_key <- string_ci new_nick;
   end
 
-let register t ~router = Hashtbl.add router.users t.nick_key t
+let register t ~router =
+  begin
+    Hashtbl.add router.users t.nick_key t;
+    Cache.add router.whowas t.nick_key (t.nick, t.userinfo);
+  end
+
 let unregister t ~router = Hashtbl.remove router.users t.nick_key
 let is_registered t ~router = Hashtbl.mem router.users t.nick_key