.gitignore

@@ -1,4 +1 @@
-_build/
+_build/
-_opam/
-_dist/
-*.install

bin/main.ml

@@ -1,12 +1,10 @@
-include (val Logging.sublogs Server.logger "Main")
-
 let min_level =
   match Sys.getenv_opt "LOG_LEVEL" |> Option.map String.uppercase_ascii with
   | Some "TRACE" -> Logging.TRACE
-  | Some "DEBUG" -> Logging.DEBUG
+  | Some "DEBUG" -> Logging.TRACE
-  | Some "INFO" -> Logging.INFO
+  | Some "INFO" -> Logging.TRACE
-  | Some ("WARN" | "WARNING") -> Logging.WARN
+  | Some ("WARN" | "WARNING") -> Logging.TRACE
-  | Some ("ERR" | "ERROR") -> Logging.ERROR
+  | Some ("ERR" | "ERROR") -> Logging.TRACE
   | _ -> Logging.INFO
 
 let no_color = Option.is_some (Sys.getenv_opt "LOG_NO_COLOR")
@@ -14,34 +12,17 @@ let no_timestamp = Option.is_some (Sys.getenv_opt "LOG_NO_TIMESTAMP")
 let no_namespace = Option.is_some (Sys.getenv_opt "LOG_NO_NAMESPACE")
 
 let () =
-  if Logging.should_upgrade_to_journald () then
+  match Sys.getenv_opt "JOURNAL_STREAM" with
+  | Some _ ->
     Logging.init_journald_writer ()
       ~min_level
-  else
+  | None ->
-    Logging.init_pretty_writer stdout
+    Logging.init_pretty_writer stderr
       ~min_level
       ~color:(not no_color)
       ~timestamp:(not no_timestamp)
       ~namespace:(not no_namespace)
 
-let sd_notify_sock =
-  Option.map
-    (fun path ->
-       let sock_fd = Unix.socket PF_UNIX SOCK_DGRAM 0 ~cloexec:true in
-       let dest = Unix.ADDR_UNIX path in
-       sock_fd, dest)
-    (Sys.getenv_opt "NOTIFY_SOCKET")
-
-let sd_notify msg =
-  Option.iter
-    (fun (sock_fd, dest) ->
-       let dgram = Bytes.of_string msg in
-       Unix.sendto sock_fd dgram 0 (Bytes.length dgram) [] dest |> ignore)
-    sd_notify_sock
-
-
-(* TODO: s-exp/json/toml config format *)
-
 let port =
   try
     let port = int_of_string (Sys.getenv "IRC_PORT") in
@@ -55,32 +36,15 @@ let hostname =
   | Some x -> x
   | None -> "irc.tali.software"
 
-let motd_file =
-  match Sys.getenv_opt "IRC_MOTD" with
-  | Some x -> x
-  | None -> "./motd.txt"
-
 let config : Server.config = {
   port;
   hostname;
   listen_backlog = 8;
   ping_interval = 60;
   whowas_history_len = 1000;
-  motd_file;
+
-  notify = function
+  (* TODO: motd *)
-    | `ready -> sd_notify "READY=1"
-    | `stopping -> sd_notify "STOPPING=1"
 }
 
 let () =
-  Printexc.register_printer
+  Lwt_main.run @@ Server.run config
-    (function
-      | Unix.Unix_error (eno, who, _) -> Some (Fmt.str "%s: %s" who (Unix.error_message eno))
-      | Failure msg -> Some ("internal error: " ^ msg)
-      | Invalid_argument who -> Some ("internal error: invalid argumnet: " ^ who)
-      | _ -> None);
-  try
-    Lwt_main.run @@ Server.run config
-  with exn ->
-    error (fun m -> m "%a" Fmt.exn exn);
-    exit 1

conf.txt

@@ -1,3 +0,0 @@
-IRC_MOTD=/etc/talircd.motd
-IRC_HOSTNAME=irc.tali.software
-IRC_PORT=6667

deploy/_build.sh

@@ -1,43 +0,0 @@
-#!/usr/bin/env bash
-
-opam init --disable-sandboxing --no-setup
-
-eval $(opam env)
-
-root=dist/root
-rm -rf $root
-mkdir -p $root/usr/lib/systemd/system $root/DEBIAN
-
-# build ocaml program
-
-opam pin add ./talircd --kind=path --no-action --yes
-opam install talircd --destdir=$root/usr --yes
-
-# install service file
-
-install -m 644 talircd/deploy/talircd.service $root/usr/lib/systemd/system
-
-# generate package control file
-
-pkg=$(opam info talircd -fname)
-ver="$(opam info talircd -fversion)"
-rev=0
-dsc="$(opam info talircd -fdescription)"
-mtr="iitalics"
-arch="$(dpkg-architecture -q DEB_TARGET_ARCH)"
-
-control=$root/DEBIAN/control
-
-set -x
-
-echo "Package: ${pkg}"        > $control
-echo "Version: ${ver}"       >> $control
-echo "Description: ${dsc}"   >> $control
-echo "Maintainer: ${mtr}"    >> $control
-echo "Architecture: ${arch}" >> $control
-
-install -m 755 talircd/deploy/postinst.sh $root/DEBIAN/postinst
-
-# generate .deb
-
-dpkg-deb --root-owner-group -b $root "dist/${pkg}_${ver}-${rev}_${arch}.deb"

deploy/deploy.sh

@@ -1,58 +0,0 @@
-#!/usr/bin/env bash
-
-MACHINE=${MACHINE:-talircd-build}
-MACHINE_PATH=/var/lib/machines/${MACHINE}
-PROJECT_ROOT=${PROJECT_ROOT:-$(git rev-parse --show-toplevel)}
-DIST_DIR=${DIST_DIR:-${PROJECT_ROOT}/_dist}
-
-CODENAME=bullseye
-MIRROR=${MIRROR:-http://debian.csail.mit.edu/debian/}
-
-function init() {
-    # TODO: fakeroot ?
-    set -x
-    sudo debootstrap \
-         --include=ocaml-base,ocaml,opam,ca-certificates,git,rsync \
-         --components=main,contrib \
-         ${CODENAME} ${MACHINE_PATH} ${MIRROR}
-}
-
-function cleanall() {
-    set -x
-    sudo rm -rf ${MACHINE_PATH}
-}
-
-function in_container() {
-    set -x
-    mkdir -p ${DIST_DIR}
-
-    sudo systemd-nspawn -q \
-         --machine ${MACHINE} \
-         --bind-ro ${PROJECT_ROOT}:/root/talircd \
-         --bind ${DIST_DIR}:/root/dist:rootidmap \
-         -E OPAMROOTISOK=1 \
-         "$@"
-}
-
-function clean() {
-    rm -rf ${DIST_DIR}/root
-    in_container rm -rf /root/.opam
-}
-
-function build() {
-    in_container --chdir /root /root/talircd/deploy/_build.sh
-}
-
-function shell() {
-    in_container
-}
-
-case ${1:-build} in
-    init) init ;;
-    build) build ;;
-    clean) clean ;;
-    cleanall) cleanall ;;
-    shell) shell ;;
-    *)
-      echo "invalid command $1"
-esac

deploy/postinst.sh

@@ -1,4 +0,0 @@
-#!/usr/bin/sh
-[ -f /etc/talircd.conf ] || install -m 644 /usr/share/talircd/default/conf /etc/talircd.conf
-[ -f /etc/talircd.motd ] || install -m 644 /usr/share/talircd/default/motd /etc/talircd.motd
-systemctl daemon-reload

deploy/talircd.service

@@ -1,9 +0,0 @@
-[Unit]
-Description=tali IRCd
-ConditionPathExists=/etc/talircd.conf
-
-[Service]
-Type=notify
-ExecStart=/usr/bin/talircd
-KillSignal=SIGTERM
-EnvironmentFile=/etc/talircd.conf

dune

@@ -1,6 +0,0 @@
-(install
- (package talircd)
- (files
-  (motd.txt as default/motd)
-  (conf.txt as default/conf))
- (section share))

dune-project

@@ -1,21 +1,13 @@
 (lang dune 3.8)
 (name talircd)
-(version 0.0.3)
-
 (generate_opam_files true)
-
 (package
  (name talircd)
- (synopsis "IRC server")
+ (depends
- (description "IRC server for cats written in ocaml")
+   ocaml
- (license "LGPL-2.0-or-later")
+   dune
- (homepage "https://git.lain.faith/iitalics/talircd/")
+   (lwt (= 5.7.0))
- (bug_reports "https://git.lain.faith/iitalics/talircd/issues")
+   (ppx_expect (= v0.16.0))
- (authors "iitalics <git.lain.faith/iitalics>")
+   (ppx_deriving (= 5.2.1))
- (maintainers "iitalics <git.lain.faith/iitalics>")
+   (fmt (= 0.9.0))
- (depends ocaml dune
+   (ptime (= 1.1.0))))
-  (lwt (>= 5.7))
-  (ppx_expect (and (>= v0.15) (< v0.17)))
-  (ppx_deriving (>= 5.2))
-  (fmt (>= 0.9))
-  (ptime (>= 1.1))))

lib/data/dllist.ml

@@ -25,12 +25,6 @@ let create () =
 
 let is_empty seq = seq.next == seq
 
-let reset seq =
-  begin
-    seq.next <- seq;
-    seq.prev <- seq;
-  end
-
 let remove node =
   if node.node_active then begin
     node.node_active <- false;
@@ -80,15 +74,6 @@ let fold_r f seq acc =
   in
   loop seq.prev acc
 
-let iter_l f seq =
-  let rec loop curr =
-    if curr != seq then
-      let node = node_of_seq curr in
-      if node.node_active then f node.node_data;
-      loop node.node_next
-  in
-  loop seq.next
-
 let find f seq =
   let rec loop curr =
     if curr == seq then

lib/data/dllist.mli

@@ -21,9 +21,6 @@ val create : unit -> 'a t
 val is_empty : 'a t -> bool
   (** Returns [true] iff the given sequence is empty *)
 
-val reset : 'a t -> unit
-  (** [reset ()] is a lazy way to remove all the elements from the sequence *)
-
 val add_l : 'a -> 'a t -> 'a node
   (** [add_l x s] adds [x] to the left of the sequence [s] *)
 
@@ -60,10 +57,6 @@ val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
       where [e1], [e2], ..., [en] are the elements of [s]
   *)
 
-val iter_l : ('a -> unit) -> 'a t -> unit
-  (** [iter_l f s] applies [f] on all elements of [s] starting from
-      the left *)
-
 val find : ('a -> bool) -> 'a t -> 'a
   (** [find_node_l f s] returns the first element of [s] starting from the left
       that satisfies [f] or raises [Not_found] if none exists. *)

lib/data/test_wheel.ml

@@ -25,11 +25,6 @@ let%expect_test _ =
   Wheel.add wh 6 |> ignore;
   (* t=3 *)
   print_ints_nl (Wheel.tick wh); [%expect {| [] |}];
-
-  let every = ref [] in
-  Wheel.iter (fun x -> every := x :: !every) wh;
-  print_ints_nl (List.sort compare !every); [%expect {| [1;2;3;4;5;6] |}];
-
   (* t=0 *)
   print_ints_nl (Wheel.tick wh); [%expect {| [1;2;3] |}];
   (* t=1 *)

lib/data/wheel.ml

@@ -22,8 +22,3 @@ let[@tail_mod_cons] rec empty t =
 let tick t =
   t.index <- (t.index + 1) mod Array.length t.entries;
   empty t
-
-let iter f t =
-  for i = 0 to Array.length t.entries - 1 do
-    Dllist.iter_l f t.entries.(i)
-  done

lib/irc/mode.ml

@@ -73,18 +73,32 @@ module Set = struct
   let add elt s = union s (singleton elt)
   let remove elt s = diff s (singleton elt)
 
-  let of_list l =
-    List.fold_left (fun s m -> add m s) empty l
-
   let to_string s =
-    Seq.filter_map
+    let bs = Bytes.create 7 in
-      (fun m -> if mem m s then Some (to_char m) else None)
+    let bit ch elt i =
-      (List.to_seq [`i; `m; `n; `o; `s; `t; `w]) |>
+      if mem elt s then (Bytes.set bs i ch; i + 1)
-    String.of_seq
+      else i
+    in
+    let n =
+      0 |> bit 'i' `i |> bit 'm' `m |> bit 'n' `n |> bit 'o' `o |>
+      bit 's' `s |> bit 't' `t |> bit 'w' `w
+    in
+    Bytes.sub_string bs 0 n
 
   let pp ppf s =
     Format.pp_print_string ppf (to_string s)
 
+  let of_string s =
+    let chr = function
+      | 'i' -> `i | 'm' -> `m | 'n' -> `n | 'o' -> `o
+      | 's' -> `s | 't' -> `t | 'w' -> `w
+      | _ -> invalid_arg "Irc.Mode.Set.of_string"
+    in
+    String.fold_left (fun s c -> add (chr c) s) empty s
+
+  let of_list l =
+    List.fold_left (fun s m -> add m s) empty l
+
   type change = {
     add : t;
     rem : t;
@@ -267,14 +281,14 @@ let%expect_test _ =
   let print_change_nl c = Format.kasprintf print_string "%a\n" Set.pp_change c in
 
   print_set_nl Set.empty; [%expect {| [] |}];
-  print_set_nl Set.(of_list [`i]); [%expect {| [i] |}];
+  print_set_nl Set.(of_string "i"); [%expect {| [i] |}];
-  print_set_nl Set.(of_list [`n;`o]); [%expect {| [no] |}];
+  print_set_nl Set.(of_string "no"); [%expect {| [no] |}];
-  print_set_nl Set.(of_list [`s;`m]); [%expect {| [ms] |}];
+  print_set_nl Set.(of_string "sm"); [%expect {| [ms] |}];
-  print_set_nl Set.(of_list [`w;`i]); [%expect {| [iw] |}];
+  print_set_nl Set.(of_string "wi"); [%expect {| [iw] |}];
-  print_bool_nl Set.(mem `i (of_list [`i;`n;`s])); [%expect "true"];
+  print_bool_nl Set.(mem `i (of_string "ins")); [%expect "true"];
-  print_bool_nl Set.(mem `w (of_list [`i;`n;`s])); [%expect "false"];
+  print_bool_nl Set.(mem `w (of_string "ins")); [%expect "false"];
-  print_bool_nl Set.(mem `w (of_list [`w;`w;`w;`w])); [%expect "true"];
+  print_bool_nl Set.(mem `w (of_string "wwww")); [%expect "true"];
-  print_bool_nl Set.(mem `t (of_list [`i;`m;`n;`o;`s;`w])); [%expect "false"];
+  print_bool_nl Set.(mem `t (of_string "imnosw")); [%expect "false"];
 
   let print_parse_error f =
     try f () |> ignore; print_endline "()"
@@ -291,8 +305,7 @@ let%expect_test _ =
   print_change_nl (Parse.user_modes "-o+o"); [%expect {| +o |}];
   print_parse_error (fun () -> Parse.user_modes "+I"); [%expect {| unknown mode I |}];
 
-  let m = Set.of_list [`i;`w] in
+  let m, c = Set.normalize (Set.of_string "iw") (Parse.user_modes "-w+io") in
-  let m, c = Set.normalize m (Parse.user_modes "-w+io") in
   Format.printf "%a -> [%a]\n@." Set.pp_change c Set.pp m;
   [%expect {| +o-w -> [io] |}];
 

lib/irc/mode.mli

@@ -45,7 +45,6 @@ module Set : sig
 
   val empty : t
   val singleton : [< elt] -> t
-  val of_list : [< elt] list -> t
   val mem : [< elt] -> t -> bool
   val add : [< elt] -> t -> t
   val remove : [< elt] -> t -> t
@@ -56,6 +55,9 @@ module Set : sig
 
   val pp : Format.formatter -> t -> unit
   val to_string : t -> string
+  val of_string : string -> t
+  val of_list : [< elt] list -> t
+  (* val to_list  : t -> elt list *)
 
   type change = {
     add : t;

lib/irc/msg.ml

@@ -21,21 +21,16 @@ type t = {
   trailing : bool;
 } [@@deriving show { with_path = false }]
 
-let rec is_trailing arg i =
+let is_param_trailing p =
-  if i >= String.length arg then
+  String.starts_with p ~prefix:":" || String.contains p ' '
-    arg = ""
-  else match arg.[i] with
-    | ' ' | '\t' -> true
-    | ':' when i = 0 -> true
-    | _ -> is_trailing arg (i + 1)
 
-let rec ends_with_trailing = function
+let rec is_params_trailing = function
   | [] -> false
-  | [p] -> is_trailing p 0
+  | [p] -> is_param_trailing p
-  | _ :: tl -> ends_with_trailing tl
+  | _ :: tl -> is_params_trailing tl
 
 let make ?(prefix = No_prefix) ?(always_trailing = false) command params =
-  let trailing = always_trailing || ends_with_trailing params in
+  let trailing = always_trailing || is_params_trailing params in
   { prefix; command; params; trailing }
 
 let write buf t =
@@ -171,12 +166,6 @@ let%expect_test _ =
   make "NICK" [":)"] |> print_msg_nl;
   [%expect {| "NICK ::)\r\n" |}];
 
-  make "NICK" ["(:"] |> print_msg_nl;
-  [%expect {| "NICK (:\r\n" |}];
-
-  make "NICK" [""] |> print_msg_nl;
-  [%expect {| "NICK :\r\n" |}];
-
   make "USER" ["milo"; "0"; "*"; "milo"] ~always_trailing:true |> print_msg_nl;
   [%expect {| "USER milo 0 * :milo\r\n" |}];
 

lib/logging/journald.ml

@@ -6,19 +6,14 @@ type t = {
   mutex : Mutex.t;
   sock_fd : Unix.file_descr;
   dest : Unix.sockaddr;
-  buf : Buffer.t;
+  dgram : Buffer.t;
 }
 
-let should_upgrade () =
-  let stderr = Unix.fstat Unix.stderr in
-  let dev_ino = Printf.sprintf "%d:%d" stderr.st_dev stderr.st_ino in
-  Sys.getenv_opt "JOURNAL_STREAM" = Some dev_ino
-
 let make ?(path = default_socket_path) () = {
   mutex = Mutex.create ();
   sock_fd = Unix.socket PF_UNIX SOCK_DGRAM 0 ~cloexec:true;
   dest = ADDR_UNIX path;
-  buf = Buffer.create 256;
+  dgram = Buffer.create 256;
 }
 
 let add_field dgram key value =
@@ -41,13 +36,11 @@ let syslog_priority = function
   | ERROR -> "3" (* LOG_ERR *)
 
 let writer t ~ts ~ns ~lvl msg =
-  Mutex.lock t.mutex;
   let dgram =
-    Buffer.clear t.buf;
+    Mutex.protect t.mutex @@ fun () ->
     ignore ts;
-    add_field t.buf "MESSAGE" (Printf.sprintf "%s: %s" ns msg);
+    add_field t.dgram "MESSAGE" (Printf.sprintf "%s: %s" ns msg);
-    add_field t.buf "PRIORITY" (syslog_priority lvl);
+    add_field t.dgram "PRIORITY" (syslog_priority lvl);
-    Buffer.to_bytes t.buf
+    Buffer.to_bytes t.dgram
   in
-  Mutex.unlock t.mutex;
   Unix.sendto t.sock_fd dgram 0 (Bytes.length dgram) [] t.dest |> ignore

lib/logging/logging.ml

@@ -107,5 +107,3 @@ let init_journald_writer
   Journald.make () ?path |>
   Journald.writer |>
   add_writer ?min_level
-
-let should_upgrade_to_journald = Journald.should_upgrade

lib/logging/logging.mli

@@ -36,5 +36,3 @@ val init_journald_writer :
   ?min_level:level ->
   ?path:string ->
   unit -> unit
-
-val should_upgrade_to_journald : unit -> bool

lib/logging/mutex.ml

@@ -1,5 +0,0 @@
-(* stub implementation since we actually aren't multithreaded *)
-type t = unit
-external create : unit -> t = "%identity"
-external lock : t -> unit = "%identity"
-external unlock : t -> unit = "%identity"

lib/logging/pretty.ml

@@ -95,7 +95,7 @@ let writer t ~ts ~ns ~lvl msg =
   let f mask = t.flags land mask = mask in
   let align bp =
     let n = t.align_to - Buffer.length bp in
-    t.align_to <- max t.align_to (Buffer.length bp);
+    t.align_to <- Buffer.length bp;
     n
   in
   let indent bp =

lib/server/chan.ml

@@ -24,7 +24,6 @@ let creation_time t = t.creation_time
 let topic t = fst t.topic
 let topic_who_time t = snd t.topic
 let set_topic ~who ?time t text = t.topic <- text, Some (who, value_or_now time)
-let member_count t = t.member_count
 let mode t = t.chan_mode
 let set_mode t new_mode = t.chan_mode <- new_mode
 let limit t = t.chan_limit

lib/server/connection.ml

@@ -280,22 +280,22 @@ let on_msg_mode t name args =
   Ok ()
 
 
-(* messages *)
+(* messages and channels *)
-
-let get_priv_opt chan user =
-  try
-    let mem = Router.membership chan user in
-    Some mem.mem_priv
-  with Not_found ->
-    None
 
 let send_to_chan ~from chan =
-  let priv_required =
+  let cannot_send =
-    if      Mode.Set.mem `m (Chan.mode chan) then Some Voice
+    try
-    else if Mode.Set.mem `n (Chan.mode chan) then Some Normal
+      let mem = Router.membership chan from in
-    else None
+      (* check if moderated (+m) *)
+      if Mode.Set.mem `m (Chan.mode chan) then
+        mem.mem_priv < Voice
+      else
+        false
+    with Not_found ->
+      (* check if no external messages (+n) *)
+      Mode.Set.mem `n (Chan.mode chan)
   in
-  if get_priv_opt chan from < priv_required then
+  if cannot_send then
     Error (cannotsendtochan (Chan.name chan))
   else
     Ok (Chan.name chan, [`to_chan chan])
@@ -336,9 +336,6 @@ let on_msg_away t status =
   set_away t me status;
   Ok ()
 
-
-(* channels *)
-
 let membership_prefix = function
   | Normal -> ""
   | Voice -> "+"
@@ -347,29 +344,30 @@ let membership_prefix = function
 let is_invisible user =
   Mode.Set.mem `i (User.mode user)
 
-let is_secret chan =
-  Mode.Set.mem `s (Chan.mode chan)
-
 let list_names t me chan =
+  let is_secret = Mode.Set.mem `s (Chan.mode chan) in
+
   let members =
     match Router.membership chan me with
     | _is_member -> Chan.membership chan
     | exception Not_found ->
-      if is_secret chan then
+      if is_secret then
         []
       else
         Chan.membership_when
           (fun mem -> not (is_invisible mem.mem_user))
           chan
   in
+
   let nicks =
     List.map
       (fun mem ->
          membership_prefix mem.mem_priv ^ User.nick mem.mem_user)
       members
   in
+
   let chan_name = Chan.name chan in
-  let chan_sym = if is_secret chan then "@" else "=" in
+  let chan_sym = if is_secret then "@" else "=" in
   begin
     (* TODO: concat member names until message becomes too long *)
     List.iter (fun nick -> reply t ("353", [chan_sym; chan_name; nick])) nicks;
@@ -619,8 +617,8 @@ let list_whois t user =
 
     reply t ("320", [nick; "is a cat, meow :3"]);
 
-    let mode = Mode.Set.{ add = User.mode user; rem = empty }in
+    reply t ("379", [nick; Fmt.str "is using modes +%s"
-    reply t ("379", [nick; Fmt.str "is using modes %a" Mode.Set.pp_change mode]);
+                             (Mode.Set.to_string (User.mode user))]);
 
     Option.iter
       (fun text ->
@@ -685,43 +683,6 @@ let on_msg_userhost t nicks =
   reply t ("302", [String.concat " " results]);
   Ok ()
 
-let list_channels t me channels =
-  begin
-    reply t ("321", ["Channel"; "Users  Name"]);
-    Seq.iter
-      (function
-        | Error err -> reply t err
-        | Ok chan ->
-          try
-            if is_secret chan then Router.membership chan me |> ignore;
-            let count = Chan.member_count chan in
-            let topic = Option.value (Chan.topic chan) ~default:"" in
-            reply t ("322", [Chan.name chan; string_of_int count; topic])
-          with Not_found ->
-            ())
-      channels;
-    reply t ("323", ["End of /LIST"]);
-  end
-
-let on_msg_list t names =
-  let* me = require_registered t in
-  let channels = match names with
-    | [] ->
-      Seq.map Result.ok
-        (Router.all_channels_seq t.router)
-    | _ ->
-      Seq.map
-        (fun name ->
-           try
-             match name_type name with
-             | `chan -> Ok (Router.find_chan t.router name)
-             | `nick | `invalid -> raise Not_found
-           with Not_found ->
-             Error (nosuchnick name))
-        (List.to_seq names)
-  in
-  list_channels t me channels;
-  Ok ()
 
 (* welcome and quit *)
 
@@ -974,8 +935,6 @@ let dispatch t = function
   | "WHOWAS", ([] | "" :: _) -> Error nonicknamegiven
   | "WHOWAS", [nick] -> on_msg_whowas t nick ""
   | "WHOWAS", nick :: count :: _ -> on_msg_whowas t nick count
-  | "LIST", chans :: _ -> on_msg_list t (String.split_on_char ',' chans)
-  | "LIST", [] -> on_msg_list t []
   | "USERHOST", nicks -> on_msg_userhost t nicks
   | ("USER" | "JOIN" | "NAMES" | "PART" | "KICK" | "MODE" | "WHO") as cmd, _ ->
     Error (needmoreparams cmd)
@@ -989,6 +948,7 @@ let dispatch t = function
       | tgt :: msg :: _ -> on_msg_privmsg t tgt msg ~cmd
     end
 
+  (* TODO: "LIST" *)
   | cmd, _ ->
     Error (unknowncommand cmd)
 
@@ -1005,6 +965,7 @@ let split_command_params cmd params =
 
   | ("PRIVMSG" | "NOTICE" | "NAMES" | "PART"), tgts :: rest
     when String.contains tgts ',' ->
+    (* TODO: "JOIN" should be handled specially *)
     String.split_on_char ',' tgts |>
     List.map (fun tgt -> cmd, tgt :: rest)
 

lib/server/dune

@@ -6,10 +6,3 @@
    logging irc data)
  (inline_tests)
  (preprocess (pps ppx_expect)))
-
-(rule
- (package talircd)
- (target "meta_server_info.ml")
- (action
-  (with-stdout-to %{target}
-   (echo "let version = \"%{version:talircd}\";;"))))

lib/server/router.ml

@@ -28,19 +28,6 @@ let find_chan t name =
 let whowas t nick =
   Cache.find_all t.whowas (string_ci nick)
 
-let all_channels_seq t =
-  Hashtbl.to_seq_values t.channels
-
-let nuke t =
-  begin
-    Hashtbl.iter (fun _ u -> Dllist.reset u.membership) t.users;
-    Hashtbl.iter (fun _ c -> Dllist.reset c.members) t.channels;
-    Hashtbl.clear t.users;
-    Hashtbl.clear t.channels;
-    t.lusers <- 0;
-    t.luserchannels <- 0;
-  end
-
 let relay ~(from : user) (msg : Msg.t) tgts =
   let msg =
     if msg.prefix = No_prefix then

lib/server/server.ml

@@ -4,29 +4,20 @@ open Lwt.Infix
 
 include (val Logging.sublogs logger "Server")
 
-type config = {
+type ping_wheel = Connection.t Wheel.t
-  port : int;
-  listen_backlog : int;
-  ping_interval : int;
-  whowas_history_len : int;
-  hostname : string;
-  motd_file : string;
-  notify : [`ready | `stopping] -> unit;
-}
 
-let bind_server
+let listener ~(port : int) ~(listen_backlog : int) : (fd * sockaddr) Lwt_stream.t =
-      ~(port : int)
+  let sock : fd Lwt.t =
-      ~(listen_backlog : int)
+    let fd = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
-  : fd Lwt.t =
+    Lwt_unix.setsockopt fd SO_KEEPALIVE false;
-  let fd = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
+    Lwt_unix.setsockopt fd SO_REUSEPORT true;
-  let srv_adr = Unix.ADDR_INET (Unix.inet_addr_any, port) in
+    let srv_adr = Unix.ADDR_INET (Unix.inet_addr_any, port) in
-  let* () = Lwt_unix.bind fd srv_adr in
+    let* () = Lwt_unix.bind fd srv_adr in
-  Lwt_unix.listen fd listen_backlog;
+    Lwt_unix.listen fd listen_backlog;
-  info (fun m -> m "listening on %a" pp_sockaddr srv_adr);
+    info (fun m -> m "listening on %a" pp_sockaddr srv_adr);
-  Lwt.return fd
+    Lwt.return fd
-
+  in
-let accepts (fd : fd) : (fd * sockaddr) Lwt_stream.t =
+  let accept () = sock >>= Lwt_unix.accept >|= Option.some in
-  let accept () = Lwt_unix.accept fd >>= Lwt.return_some in
   Lwt_stream.from accept
 
 let reader (fd : fd) : Msg.t Lwt_stream.t =
@@ -75,7 +66,7 @@ let handle_client
       (conn_addr : sockaddr)
       ~(server_info : Server_info.t)
       ~(router : Router.t)
-      ~(ping_wheel : Connection.t Wheel.t)
+      ~(ping_wheel : ping_wheel)
   =
   info (fun m -> m "new connection %a" pp_sockaddr conn_addr);
   let conn : Connection.t =
@@ -101,60 +92,23 @@ let handle_client
       (fun e -> error (fun m -> m "%a:@ %a" pp_sockaddr conn_addr Fmt.exn e));
   end
 
-let interval dt =
+type config = {
-  let tick () =
+  port : int;
-    let* () = Lwt_unix.sleep dt in
+  listen_backlog : int;
-    Lwt.return_some ()
+  ping_interval : int;
-  in
+  whowas_history_len : int;
-  Lwt_stream.from tick
+  hostname : string;
-
+  (* TODO: motd *)
-let interrupt () =
+}
-  let signal, signal_waiter = Lwt.wait () in
-  let on_signal num =
-    trace (fun m -> m "caught signal %d" num);
-    try Lwt.wakeup signal_waiter () with
-      Invalid_argument _ -> failwith "unceremoniously exiting"
-  in
-  Lwt_unix.on_signal (2 (* SIGINT *)) on_signal |> ignore;
-  Lwt_unix.on_signal (15 (* SIGTERM *)) on_signal |> ignore;
-  signal
-
-let run {
-      port;
-      listen_backlog;
-      ping_interval;
-      whowas_history_len;
-      hostname;
-      motd_file;
-      notify;
-    }
-  : unit Lwt.t =
-  debug (fun m -> m "ping interval:@ %ds" ping_interval);
-  debug (fun m -> m "whowas history:@ %d" whowas_history_len);
-
-  let* motd =
-    let* file = Lwt_io.open_file motd_file ~mode:Input in
-    let* lines = Lwt_io.read_lines file |> Lwt_stream.to_list in
-    let+ () = Lwt_io.close file in
-    debug (fun m -> m "motd file:@ %d lines" (List.length lines));
-    lines
-  in
 
+let run { port; listen_backlog; ping_interval;
+          whowas_history_len; hostname } : unit Lwt.t
+  =
   let server_info =
-    Server_info.make ()
+    Server_info.make
       ~hostname
-      ~motd
+      (* ~motd *)
   in
-  info (fun m -> m "hostname:@ %s" server_info.hostname);
-  info (fun m -> m "version:@ %s" server_info.version);
-  info (fun m -> m "created:@ %s" server_info.created);
-
-  let* server : fd =
-    bind_server
-      ~port
-      ~listen_backlog
-  in
-  notify `ready;
 
   let router : Router.t =
     Router.make
@@ -166,45 +120,37 @@ let run {
       ping_interval
   in
 
-  let ping conn =
+  let on_tick () =
-    match Connection.on_ping conn with
+    (* trace (fun m -> m "tick"); *)
-    | Ok () -> Wheel.add ping_wheel conn
+    List.iter
-    | Error _ -> Connection.close conn ~reason:"Connection timeout"
+      (fun conn ->
+         match Connection.on_ping conn with
+         | Ok () -> Wheel.add ping_wheel conn
+         | Error () -> Connection.close conn ~reason:"Connection timed out")
+      (Wheel.tick ping_wheel)
   in
 
   let pinger_promise =
     Lwt_stream.iter
-      (fun () ->
+      on_tick
-         List.iter ping
+      (Lwt_stream.from @@ fun () ->
-           (Wheel.tick ping_wheel))
+       let* () = Lwt_unix.sleep 1.0 in
-      (interval 1.0)
+       Lwt.return_some ())
+  in
+
+  let on_con (fd, adr) =
+    handle_client fd adr
+      ~server_info
+      ~router
+      ~ping_wheel
   in
 
   let listener_promise =
     Lwt_stream.iter
-      (fun (fd, addr) ->
+      on_con
-         handle_client fd addr
+      (listener
-           ~server_info
+         ~port
-           ~router
+         ~listen_backlog)
-           ~ping_wheel)
-      (accepts server)
   in
 
-  let* () =
+  listener_promise <&> pinger_promise
-    Lwt.pick [
-      listener_promise <?> pinger_promise;
-      interrupt ()
-    ]
-  in
-  notify `stopping;
-
-  info (fun m -> m "shutting down");
-  let* () = Lwt_unix.close server in
-
-  Router.nuke router;
-  Wheel.iter (fun conn -> Connection.close conn ~reason:"Server shutting down")
-    (* ping wheel should contain every active connection *)
-    ping_wheel;
-
-  (* give some time for the messages to send *)
-  Lwt_unix.sleep 0.5

lib/server/server_info.ml

@@ -1,7 +1,4 @@
 open! Import
-include (Meta_server_info : sig
-           val version : string
-         end)
 
 let tz_offset_s = Ptime_clock.current_tz_offset_s ()
 let pp_time = Ptime.pp_human () ?tz_offset_s
@@ -40,13 +37,22 @@ let default_conf = {
   init_cmode = Mode.Set.of_list [`n; `s; `t];
 }
 
-let make ?(conf = default_conf) ~hostname ~motd () = {
+let make ~hostname = {
-  version;
+  version =
+    (* TODO: generate version string at build time? *)
+    "0.0.0";
   created = Fmt.str "%a" pp_time (Ptime_clock.now ());
-  admin_info = "the admin of this server is @iitalics@octodon.social";
   hostname;
-  motd;
+  admin_info =
-  conf;
+    (* TODO: make configurable *)
+    "the admin of this server is @iitalics@octodon.social";
+  motd = [
+    (* TODO: load from file *)
+    "MEOW MEOW MEOW MEOW MEOW";
+    "meow meow meow meow meow";
+    "meowmeowmeowmeowmeowmeow";
+  ];
+  conf = default_conf;
 }
 
 let prefix t = Msg.Server_prefix t.hostname

motd.txt

@@ -1,6 +0,0 @@
---------------------------------------------
-MEOW MEOW MEOW MEOW MEOW MEOW MEOW MEOW MEOW
-Meow Meow Meow Meow Meow Meow Meow Meow Meow
-meow meow meow meow meow meow meow meow meow
-meow meow meow meow meow meow meow meow meow
---------------------------------------------

talircd.opam

@@ -1,21 +1,13 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.0.3"
-synopsis: "IRC server"
-description: "IRC server for cats written in ocaml"
-maintainer: ["iitalics <git.lain.faith/iitalics>"]
-authors: ["iitalics <git.lain.faith/iitalics>"]
-license: "LGPL-2.0-or-later"
-homepage: "https://git.lain.faith/iitalics/talircd/"
-bug-reports: "https://git.lain.faith/iitalics/talircd/issues"
 depends: [
   "ocaml"
   "dune" {>= "3.8"}
-  "lwt" {>= "5.7"}
+  "lwt" {= "5.7.0"}
-  "ppx_expect" {>= "v0.15" & < "v0.17"}
+  "ppx_expect" {= "v0.16.0"}
-  "ppx_deriving" {>= "5.2"}
+  "ppx_deriving" {= "5.2.1"}
-  "fmt" {>= "0.9"}
+  "fmt" {= "0.9.0"}
-  "ptime" {>= "1.1"}
+  "ptime" {= "1.1.0"}
   "odoc" {with-doc}
 ]
 build: [

talircd.service

@@ -0,0 +1,8 @@
+[Unit]
+Description=tali IRCd
+
+[Service]
+Environment=IRC_HOSTNAME=irc.tali.software
+#Environment=IRC_PORT=6667
+#Environment=LOG_LEVEL=DEBUG
+ExecStart=/usr/local/bin/talircd