fix JOURNAL_STREAM detection to make sure its actually a sd service

- clear dgram buffer before sending to journald
- only change pretty alignment to be bigger

.gitignore

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

bin/main.ml

@@ -1,10 +1,12 @@
+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.TRACE
+  | Some "DEBUG" -> Logging.DEBUG
-  | Some "INFO" -> Logging.TRACE
+  | Some "INFO" -> Logging.INFO
-  | Some ("WARN" | "WARNING") -> Logging.TRACE
+  | Some ("WARN" | "WARNING") -> Logging.WARN
-  | Some ("ERR" | "ERROR") -> Logging.TRACE
+  | Some ("ERR" | "ERROR") -> Logging.ERROR
   | _ -> Logging.INFO
 
 let no_color = Option.is_some (Sys.getenv_opt "LOG_NO_COLOR")
@@ -12,17 +14,34 @@ 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 () =
-  match Sys.getenv_opt "JOURNAL_STREAM" with
+  if Logging.should_upgrade_to_journald () then
-  | Some _ ->
     Logging.init_journald_writer ()
       ~min_level
-  | None ->
+  else
-    Logging.init_pretty_writer stderr
+    Logging.init_pretty_writer stdout
       ~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
@@ -36,15 +55,32 @@ 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;
-  (* TODO: motd *)
+  notify = function
+    | `ready -> sd_notify "READY=1"
+    | `stopping -> sd_notify "STOPPING=1"
 }
 
 let () =
-  Lwt_main.run @@ Server.run config
+  Printexc.register_printer
+    (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

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

deploy/_build.sh

@@ -0,0 +1,43 @@
+#!/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

@@ -0,0 +1,58 @@
+#!/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

@@ -0,0 +1,4 @@
+#!/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

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

dune

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

dune-project

@@ -1,13 +1,21 @@
 (lang dune 3.8)
 (name talircd)
+(version 0.0.3)
+
 (generate_opam_files true)
+
 (package
  (name talircd)
- (depends
+ (synopsis "IRC server")
-   ocaml
+ (description "IRC server for cats written in ocaml")
-   dune
+ (license "LGPL-2.0-or-later")
-   (lwt (= 5.7.0))
+ (homepage "https://git.lain.faith/iitalics/talircd/")
-   (ppx_expect (= v0.16.0))
+ (bug_reports "https://git.lain.faith/iitalics/talircd/issues")
-   (ppx_deriving (= 5.2.1))
+ (authors "iitalics <git.lain.faith/iitalics>")
-   (fmt (= 0.9.0))
+ (maintainers "iitalics <git.lain.faith/iitalics>")
-   (ptime (= 1.1.0))))
+ (depends ocaml dune
+  (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,6 +25,12 @@ 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;
@@ -74,6 +80,15 @@ 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,6 +21,9 @@ 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] *)
 
@@ -57,6 +60,10 @@ 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,6 +25,11 @@ 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,3 +22,8 @@ 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,32 +73,18 @@ 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 =
-    let bs = Bytes.create 7 in
+    Seq.filter_map
-    let bit ch elt i =
+      (fun m -> if mem m s then Some (to_char m) else None)
-      if mem elt s then (Bytes.set bs i ch; i + 1)
+      (List.to_seq [`i; `m; `n; `o; `s; `t; `w]) |>
-      else i
+    String.of_seq
-    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;
@@ -281,14 +267,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_string "i"); [%expect {| [i] |}];
+  print_set_nl Set.(of_list [`i]); [%expect {| [i] |}];
-  print_set_nl Set.(of_string "no"); [%expect {| [no] |}];
+  print_set_nl Set.(of_list [`n;`o]); [%expect {| [no] |}];
-  print_set_nl Set.(of_string "sm"); [%expect {| [ms] |}];
+  print_set_nl Set.(of_list [`s;`m]); [%expect {| [ms] |}];
-  print_set_nl Set.(of_string "wi"); [%expect {| [iw] |}];
+  print_set_nl Set.(of_list [`w;`i]); [%expect {| [iw] |}];
-  print_bool_nl Set.(mem `i (of_string "ins")); [%expect "true"];
+  print_bool_nl Set.(mem `i (of_list [`i;`n;`s])); [%expect "true"];
-  print_bool_nl Set.(mem `w (of_string "ins")); [%expect "false"];
+  print_bool_nl Set.(mem `w (of_list [`i;`n;`s])); [%expect "false"];
-  print_bool_nl Set.(mem `w (of_string "wwww")); [%expect "true"];
+  print_bool_nl Set.(mem `w (of_list [`w;`w;`w;`w])); [%expect "true"];
-  print_bool_nl Set.(mem `t (of_string "imnosw")); [%expect "false"];
+  print_bool_nl Set.(mem `t (of_list [`i;`m;`n;`o;`s;`w])); [%expect "false"];
 
   let print_parse_error f =
     try f () |> ignore; print_endline "()"
@@ -305,7 +291,8 @@ 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, c = Set.normalize (Set.of_string "iw") (Parse.user_modes "-w+io") in
+  let m = Set.of_list [`i;`w] 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,6 +45,7 @@ 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
@@ -55,9 +56,6 @@ 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,16 +21,21 @@ type t = {
   trailing : bool;
 } [@@deriving show { with_path = false }]
 
-let is_param_trailing p =
+let rec is_trailing arg i =
-  String.starts_with p ~prefix:":" || String.contains p ' '
+  if i >= String.length arg then
+    arg = ""
+  else match arg.[i] with
+    | ' ' | '\t' -> true
+    | ':' when i = 0 -> true
+    | _ -> is_trailing arg (i + 1)
 
-let rec is_params_trailing = function
+let rec ends_with_trailing = function
   | [] -> false
-  | [p] -> is_param_trailing p
+  | [p] -> is_trailing p 0
-  | _ :: tl -> is_params_trailing tl
+  | _ :: tl -> ends_with_trailing tl
 
 let make ?(prefix = No_prefix) ?(always_trailing = false) command params =
-  let trailing = always_trailing || is_params_trailing params in
+  let trailing = always_trailing || ends_with_trailing params in
   { prefix; command; params; trailing }
 
 let write buf t =
@@ -166,6 +171,12 @@ 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,14 +6,19 @@ type t = {
   mutex : Mutex.t;
   sock_fd : Unix.file_descr;
   dest : Unix.sockaddr;
-  dgram : Buffer.t;
+  buf : 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;
-  dgram = Buffer.create 256;
+  buf = Buffer.create 256;
 }
 
 let add_field dgram key value =
@@ -36,11 +41,13 @@ let syslog_priority = function
   | ERROR -> "3" (* LOG_ERR *)
 
 let writer t ~ts ~ns ~lvl msg =
+  Mutex.lock t.mutex;
   let dgram =
-    Mutex.protect t.mutex @@ fun () ->
+    Buffer.clear t.buf;
     ignore ts;
-    add_field t.dgram "MESSAGE" (Printf.sprintf "%s: %s" ns msg);
+    add_field t.buf "MESSAGE" (Printf.sprintf "%s: %s" ns msg);
-    add_field t.dgram "PRIORITY" (syslog_priority lvl);
+    add_field t.buf "PRIORITY" (syslog_priority lvl);
-    Buffer.to_bytes t.dgram
+    Buffer.to_bytes t.buf
   in
+  Mutex.unlock t.mutex;
   Unix.sendto t.sock_fd dgram 0 (Bytes.length dgram) [] t.dest |> ignore

lib/logging/logging.ml

@@ -107,3 +107,5 @@ 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,3 +36,5 @@ val init_journald_writer :
   ?min_level:level ->
   ?path:string ->
   unit -> unit
+
+val should_upgrade_to_journald : unit -> bool

lib/logging/mutex.ml

@@ -0,0 +1,5 @@
+(* 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 <- Buffer.length bp;
+    t.align_to <- max t.align_to (Buffer.length bp);
     n
   in
   let indent bp =

lib/server/chan.ml

@@ -24,6 +24,7 @@ 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 and channels *)
+(* messages *)
+
+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 cannot_send =
+  let priv_required =
-    try
+    if      Mode.Set.mem `m (Chan.mode chan) then Some Voice
-      let mem = Router.membership chan from in
+    else if Mode.Set.mem `n (Chan.mode chan) then Some Normal
-      (* check if moderated (+m) *)
+    else None
-      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 cannot_send then
+  if get_priv_opt chan from < priv_required then
     Error (cannotsendtochan (Chan.name chan))
   else
     Ok (Chan.name chan, [`to_chan chan])
@@ -336,6 +336,9 @@ let on_msg_away t status =
   set_away t me status;
   Ok ()
 
+
+(* channels *)
+
 let membership_prefix = function
   | Normal -> ""
   | Voice -> "+"
@@ -344,30 +347,29 @@ let membership_prefix = function
 let is_invisible user =
   Mode.Set.mem `i (User.mode user)
 
-let list_names t me chan =
+let is_secret chan =
-  let is_secret = Mode.Set.mem `s (Chan.mode chan) in
+  Mode.Set.mem `s (Chan.mode chan)
 
+let list_names t me chan =
   let members =
     match Router.membership chan me with
     | _is_member -> Chan.membership chan
     | exception Not_found ->
-      if is_secret then
+      if is_secret chan 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 then "@" else "=" in
+  let chan_sym = if is_secret chan 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;
@@ -617,8 +619,8 @@ let list_whois t user =
 
     reply t ("320", [nick; "is a cat, meow :3"]);
 
-    reply t ("379", [nick; Fmt.str "is using modes +%s"
+    let mode = Mode.Set.{ add = User.mode user; rem = empty }in
-                             (Mode.Set.to_string (User.mode user))]);
+    reply t ("379", [nick; Fmt.str "is using modes %a" Mode.Set.pp_change mode]);
 
     Option.iter
       (fun text ->
@@ -683,6 +685,43 @@ 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 *)
 
@@ -935,6 +974,8 @@ 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)
@@ -948,7 +989,6 @@ let dispatch t = function
       | tgt :: msg :: _ -> on_msg_privmsg t tgt msg ~cmd
     end
 
-  (* TODO: "LIST" *)
   | cmd, _ ->
     Error (unknowncommand cmd)
 
@@ -965,7 +1005,6 @@ 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,3 +6,10 @@
    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,6 +28,19 @@ 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,20 +4,29 @@ open Lwt.Infix
 
 include (val Logging.sublogs logger "Server")
 
-type ping_wheel = Connection.t Wheel.t
+type config = {
+  port : int;
+  listen_backlog : int;
+  ping_interval : int;
+  whowas_history_len : int;
+  hostname : string;
+  motd_file : string;
+  notify : [`ready | `stopping] -> unit;
+}
 
-let listener ~(port : int) ~(listen_backlog : int) : (fd * sockaddr) Lwt_stream.t =
+let bind_server
-  let sock : fd Lwt.t =
+      ~(port : int)
-    let fd = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
+      ~(listen_backlog : int)
-    Lwt_unix.setsockopt fd SO_KEEPALIVE false;
+  : fd Lwt.t =
-    Lwt_unix.setsockopt fd SO_REUSEPORT true;
+  let fd = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
-    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 accept () = sock >>= Lwt_unix.accept >|= Option.some in
+let accepts (fd : fd) : (fd * sockaddr) Lwt_stream.t =
+  let accept () = Lwt_unix.accept fd >>= Lwt.return_some in
   Lwt_stream.from accept
 
 let reader (fd : fd) : Msg.t Lwt_stream.t =
@@ -66,7 +75,7 @@ let handle_client
       (conn_addr : sockaddr)
       ~(server_info : Server_info.t)
       ~(router : Router.t)
-      ~(ping_wheel : ping_wheel)
+      ~(ping_wheel : Connection.t Wheel.t)
   =
   info (fun m -> m "new connection %a" pp_sockaddr conn_addr);
   let conn : Connection.t =
@@ -92,23 +101,60 @@ let handle_client
       (fun e -> error (fun m -> m "%a:@ %a" pp_sockaddr conn_addr Fmt.exn e));
   end
 
-type config = {
+let interval dt =
-  port : int;
+  let tick () =
-  listen_backlog : int;
+    let* () = Lwt_unix.sleep dt in
-  ping_interval : int;
+    Lwt.return_some ()
-  whowas_history_len : int;
-  hostname : string;
-  (* TODO: motd *)
-}
-
-let run { port; listen_backlog; ping_interval;
-          whowas_history_len; hostname } : unit Lwt.t
-  =
-  let server_info =
-    Server_info.make
-      ~hostname
-      (* ~motd *)
   in
+  Lwt_stream.from tick
+
+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 server_info =
+    Server_info.make ()
+      ~hostname
+      ~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
@@ -120,37 +166,45 @@ let run { port; listen_backlog; ping_interval;
       ping_interval
   in
 
-  let on_tick () =
+  let ping conn =
-    (* trace (fun m -> m "tick"); *)
+    match Connection.on_ping conn with
-    List.iter
+    | Ok () -> Wheel.add ping_wheel conn
-      (fun conn ->
+    | Error _ -> Connection.close conn ~reason:"Connection timeout"
-         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
-      on_tick
+      (fun () ->
-      (Lwt_stream.from @@ fun () ->
+         List.iter ping
-       let* () = Lwt_unix.sleep 1.0 in
+           (Wheel.tick ping_wheel))
-       Lwt.return_some ())
+      (interval 1.0)
-  in
-
-  let on_con (fd, adr) =
-    handle_client fd adr
-      ~server_info
-      ~router
-      ~ping_wheel
   in
 
   let listener_promise =
     Lwt_stream.iter
-      on_con
+      (fun (fd, addr) ->
-      (listener
+         handle_client fd addr
-         ~port
+           ~server_info
-         ~listen_backlog)
+           ~router
+           ~ping_wheel)
+      (accepts server)
   in
 
-  listener_promise <&> pinger_promise
+  let* () =
+    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,4 +1,7 @@
 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
@@ -37,22 +40,13 @@ let default_conf = {
   init_cmode = Mode.Set.of_list [`n; `s; `t];
 }
 
-let make ~hostname = {
+let make ?(conf = default_conf) ~hostname ~motd () = {
-  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;
-  admin_info =
+  motd;
-    (* TODO: make configurable *)
+  conf;
-    "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

@@ -0,0 +1,6 @@
+--------------------------------------------
+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,13 +1,21 @@
 # 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.0"}
+  "lwt" {>= "5.7"}
-  "ppx_expect" {= "v0.16.0"}
+  "ppx_expect" {>= "v0.15" & < "v0.17"}
-  "ppx_deriving" {= "5.2.1"}
+  "ppx_deriving" {>= "5.2"}
-  "fmt" {= "0.9.0"}
+  "fmt" {>= "0.9"}
-  "ptime" {= "1.1.0"}
+  "ptime" {>= "1.1"}
   "odoc" {with-doc}
 ]
 build: [

talircd.service

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