improve error messages in main somewhat

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

bin/main.ml

@@ -1,3 +1,5 @@
+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
@@ -23,6 +25,24 @@ let () =
       ~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 +56,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;
-
-  (* TODO: motd *)
+  motd_file;
+  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

lib/logging/journald.ml

@@ -6,14 +6,14 @@ type t = {
   mutex : Mutex.t;
   sock_fd : Unix.file_descr;
   dest : Unix.sockaddr;
-  dgram : Buffer.t;
+  buf : Buffer.t;
 }
 
 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 =
@@ -38,9 +38,10 @@ let syslog_priority = function
 let writer t ~ts ~ns ~lvl msg =
   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.dgram "PRIORITY" (syslog_priority lvl);
-    Buffer.to_bytes t.dgram
+    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
   Unix.sendto t.sock_fd dgram 0 (Bytes.length dgram) [] t.dest |> ignore

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/server.ml

@@ -4,16 +4,31 @@ open Lwt.Infix
 
 include (val Logging.sublogs logger "Server")
 
+type config = {
+  port : int;
+  listen_backlog : int;
+  ping_interval : int;
+  whowas_history_len : int;
+  hostname : string;
+  motd_file : string;
+  notify : [`ready | `stopping] -> unit;
+}
+
 type ping_wheel = Connection.t Wheel.t
 
-let listener ~(port : int) ~(listen_backlog : int) : (fd * sockaddr) Lwt_stream.t =
+let listener
+      ~(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 true;
+    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
@@ -92,24 +107,36 @@ let handle_client
       (fun e -> error (fun m -> m "%a:@ %a" pp_sockaddr conn_addr Fmt.exn e));
   end
 
-type config = {
-  port : int;
-  listen_backlog : int;
-  ping_interval : int;
-  whowas_history_len : int;
-  hostname : string;
-  (* TODO: motd *)
-}
+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 run { port; listen_backlog; ping_interval;
-          whowas_history_len; hostname } : unit Lwt.t
-  =
-  let server_info =
-    Server_info.make
-      ~hostname
-      (* ~motd *)
+  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 router : Router.t =
     Router.make
       ~whowas_history_len
@@ -150,7 +177,10 @@ let run { port; listen_backlog; ping_interval;
       on_con
       (listener
          ~port
-         ~listen_backlog)
+         ~listen_backlog
+         ~on_ready:(fun () -> notify `ready))
   in
 
+  (* TODO: graceful cleanup on ctrl-c *)
+
   listener_promise <&> pinger_promise

lib/server/server_info.ml

@@ -37,22 +37,17 @@ let default_conf = {
   init_cmode = Mode.Set.of_list [`n; `s; `t];
 }
 
-let make ~hostname = {
-  version =
-    (* TODO: generate version string at build time? *)
-    "0.0.0";
+let admin_info = "the admin of this server is @iitalics@octodon.social"
+let version = "0.0.0"
+(* TODO: generate version string at build time? *)
+
+let make ?(conf = default_conf) ~hostname ~motd () = {
+  version = version;
   created = Fmt.str "%a" pp_time (Ptime_clock.now ());
   hostname;
-  admin_info =
-    (* 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;
+  admin_info;
+  motd;
+  conf;
 }
 
 let prefix t = Msg.Server_prefix t.hostname

talircd.service

@@ -3,6 +3,9 @@ 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