fix JOURNAL_STREAM detection to make sure its actually a sd service

.gitignore

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

bin/main.ml

@@ -3,10 +3,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.TRACE
-  | Some "INFO" -> Logging.TRACE
-  | Some ("WARN" | "WARNING") -> Logging.TRACE
-  | Some ("ERR" | "ERROR") -> Logging.TRACE
+  | Some "DEBUG" -> Logging.DEBUG
+  | Some "INFO" -> Logging.INFO
+  | Some ("WARN" | "WARNING") -> Logging.WARN
+  | Some ("ERR" | "ERROR") -> Logging.ERROR
   | _ -> Logging.INFO
 
 let no_color = Option.is_some (Sys.getenv_opt "LOG_NO_COLOR")
@@ -14,12 +14,11 @@ 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
-  | Some _ ->
+  if Logging.should_upgrade_to_journald () then
     Logging.init_journald_writer ()
       ~min_level
-  | None ->
-    Logging.init_pretty_writer stderr
+  else
+    Logging.init_pretty_writer stdout
       ~min_level
       ~color:(not no_color)
       ~timestamp:(not no_timestamp)

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,6 +1,6 @@
 (lang dune 3.8)
 (name talircd)
-(version 0.0.1)
+(version 0.0.3)
 
 (generate_opam_files true)
 
@@ -14,8 +14,8 @@
  (authors "iitalics <git.lain.faith/iitalics>")
  (maintainers "iitalics <git.lain.faith/iitalics>")
  (depends ocaml dune
-  (lwt (= 5.7.0))
-  (ppx_expect (= v0.16.0))
-  (ppx_deriving (= 5.2.1))
-  (fmt (= 0.9.0))
-  (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,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
-    let bit ch elt i =
-      if mem elt s then (Bytes.set bs i ch; i + 1)
-      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
+    Seq.filter_map
+      (fun m -> if mem m s then Some (to_char m) else None)
+      (List.to_seq [`i; `m; `n; `o; `s; `t; `w]) |>
+    String.of_seq
 
   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_string "no"); [%expect {| [no] |}];
-  print_set_nl Set.(of_string "sm"); [%expect {| [ms] |}];
-  print_set_nl Set.(of_string "wi"); [%expect {| [iw] |}];
-  print_bool_nl Set.(mem `i (of_string "ins")); [%expect "true"];
-  print_bool_nl Set.(mem `w (of_string "ins")); [%expect "false"];
-  print_bool_nl Set.(mem `w (of_string "wwww")); [%expect "true"];
-  print_bool_nl Set.(mem `t (of_string "imnosw")); [%expect "false"];
+  print_set_nl Set.(of_list [`i]); [%expect {| [i] |}];
+  print_set_nl Set.(of_list [`n;`o]); [%expect {| [no] |}];
+  print_set_nl Set.(of_list [`s;`m]); [%expect {| [ms] |}];
+  print_set_nl Set.(of_list [`w;`i]); [%expect {| [iw] |}];
+  print_bool_nl Set.(mem `i (of_list [`i;`n;`s])); [%expect "true"];
+  print_bool_nl Set.(mem `w (of_list [`i;`n;`s])); [%expect "false"];
+  print_bool_nl Set.(mem `w (of_list [`w;`w;`w;`w])); [%expect "true"];
+  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 =
-  String.starts_with p ~prefix:":" || String.contains p ' '
+let rec is_trailing arg i =
+  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
-  | _ :: tl -> is_params_trailing tl
+  | [p] -> is_trailing p 0
+  | _ :: 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

@@ -9,6 +9,11 @@ type 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;
@@ -36,12 +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.buf "MESSAGE" (Printf.sprintf "%s: %s" ns msg);
     add_field t.buf "PRIORITY" (syslog_priority lvl);
     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/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 =
-    try
-      let mem = Router.membership chan from in
-      (* 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)
+  let priv_required =
+    if      Mode.Set.mem `m (Chan.mode chan) then Some Voice
+    else if Mode.Set.mem `n (Chan.mode chan) then Some Normal
+    else None
   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 = Mode.Set.mem `s (Chan.mode chan) in
+let is_secret chan =
+  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"
-                             (Mode.Set.to_string (User.mode user))]);
+    let mode = Mode.Set.{ add = User.mode user; rem = empty }in
+    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/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

@@ -14,25 +14,19 @@ type config = {
   notify : [`ready | `stopping] -> unit;
 }
 
-type ping_wheel = Connection.t Wheel.t
-
-let listener
+let bind_server
       ~(port : int)
       ~(listen_backlog : int)
-      ~(on_ready : unit -> unit)
-  : (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 false;
-    let srv_adr = Unix.ADDR_INET (Unix.inet_addr_any, port) in
-    let* () = Lwt_unix.bind fd srv_adr in
-    Lwt_unix.listen fd listen_backlog;
-    on_ready ();
-    info (fun m -> m "listening on %a" pp_sockaddr srv_adr);
-    Lwt.return fd
-  in
-  let accept () = sock >>= Lwt_unix.accept >|= Option.some in
+  : fd Lwt.t =
+  let fd = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
+  let srv_adr = Unix.ADDR_INET (Unix.inet_addr_any, port) in
+  let* () = Lwt_unix.bind fd srv_adr in
+  Lwt_unix.listen fd listen_backlog;
+  info (fun m -> m "listening on %a" pp_sockaddr srv_adr);
+  Lwt.return fd
+
+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 =
@@ -81,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 =
@@ -107,6 +101,24 @@ let handle_client
       (fun e -> error (fun m -> m "%a:@ %a" pp_sockaddr conn_addr Fmt.exn e));
   end
 
+let interval dt =
+  let tick () =
+    let* () = Lwt_unix.sleep dt in
+    Lwt.return_some ()
+  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;
@@ -137,6 +149,13 @@ let run {
   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
       ~whowas_history_len
@@ -147,40 +166,45 @@ let run {
       ping_interval
   in
 
-  let on_tick () =
-    (* trace (fun m -> m "tick"); *)
-    List.iter
-      (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)
+  let ping conn =
+    match Connection.on_ping conn with
+    | Ok () -> Wheel.add ping_wheel conn
+    | Error _ -> Connection.close conn ~reason:"Connection timeout"
   in
 
   let pinger_promise =
     Lwt_stream.iter
-      on_tick
-      (Lwt_stream.from @@ fun () ->
-       let* () = Lwt_unix.sleep 1.0 in
-       Lwt.return_some ())
-  in
-
-  let on_con (fd, adr) =
-    handle_client fd adr
-      ~server_info
-      ~router
-      ~ping_wheel
+      (fun () ->
+         List.iter ping
+           (Wheel.tick ping_wheel))
+      (interval 1.0)
   in
 
   let listener_promise =
     Lwt_stream.iter
-      on_con
-      (listener
-         ~port
-         ~listen_backlog
-         ~on_ready:(fun () -> notify `ready))
+      (fun (fd, addr) ->
+         handle_client fd addr
+           ~server_info
+           ~router
+           ~ping_wheel)
+      (accepts server)
   in
 
-  (* TODO: graceful cleanup on ctrl-c *)
+  let* () =
+    Lwt.pick [
+      listener_promise <?> pinger_promise;
+      interrupt ()
+    ]
+  in
+  notify `stopping;
 
-  listener_promise <&> pinger_promise
+  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

talircd.opam

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

talircd.service

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