add logging library

bin/dune

@@ -2,5 +2,5 @@
  (public_name talircd)
  (name main)
  (libraries
-   lwt lwt.unix logs fmt
-   server))
+   lwt lwt.unix fmt
+   logging server))

bin/main.ml

@@ -1,5 +1,5 @@
-Logs.set_level (Some Debug);
-Logs.set_reporter (Logs.format_reporter ());
+Logging.init_pretty_writer stderr
+  ~min_level:DEBUG;
 
 Lwt_main.run
   (Server.run {

lib/logging/dune

@@ -0,0 +1,4 @@
+(library
+ (package talircd)
+ (name logging)
+ (libraries unix))

lib/logging/logging.ml

@@ -0,0 +1,192 @@
+type level =
+  | TRACE
+  | DEBUG
+  | INFO
+  | WARN
+  | ERROR
+
+let lvl = function
+  | TRACE -> 0
+  | DEBUG -> 1
+  | INFO  -> 2
+  | WARN  -> 3
+  | ERROR -> 4
+
+let max_lvl = 5
+
+type writer =
+  ts:float ->
+  ns:string ->
+  lvl:int ->
+  string ->
+  unit
+
+let ( +++ ) w1 w2 ~ts ~ns ~lvl msg =
+  w1 ~ts ~ns ~lvl msg;
+  w2 ~ts ~ns ~lvl msg
+
+type logger = {
+  namespace : string;
+  mutable child : logger;
+  sibling : logger;
+  mutable min_lvl : int;
+  mutable writers : writer option;
+}
+
+let rec root_logger = {
+  namespace = "";
+  min_lvl = 0;
+  child = root_logger;
+  sibling = root_logger;
+  writers = None;
+}
+
+let make_logger parent_logger ns =
+  let namespace =
+    if parent_logger == root_logger then ns
+    else String.concat "." [parent_logger.namespace; ns];
+  in
+  let rec logger = {
+    namespace;
+    min_lvl = max_lvl;
+    child = logger;
+    sibling = parent_logger.child;
+    writers = None;
+  } in
+  parent_logger.child <- logger;
+  logger
+
+type 'a log_function =
+  ((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
+
+let write logger lvl msg =
+  let ts = Unix.gettimeofday () in
+  let ns = logger.namespace in
+  Option.iter (fun w -> w ~ts ~ns ~lvl msg) logger.writers
+
+let[@inline] log_write logger lvl : _ log_function = fun logk ->
+  if lvl >= logger.min_lvl then
+    logk (fun fmt ->
+           Format.kasprintf (write logger lvl)
+             ("@[<hov>" ^^ fmt))
+
+
+module type Logs = sig
+  val logger : logger
+  val trace : _ log_function
+  val debug : _ log_function
+  val info  : _ log_function
+  val warn  : _ log_function
+  val error : _ log_function
+  val log   : level -> _ log_function
+end
+
+let make_logs parent_logger ns =
+  (module struct
+    let logger = make_logger parent_logger ns
+    let[@inline] trace k = log_write logger 0 k
+    let[@inline] debug k = log_write logger 1 k
+    let[@inline] info  k = log_write logger 2 k
+    let[@inline] warn  k = log_write logger 3 k
+    let[@inline] error k = log_write logger 4 k
+    let[@inline] log level k = log_write logger (lvl level) k
+  end : Logs)
+
+let logs ns = make_logs root_logger ns
+let sublogs logger ns = make_logs logger ns
+
+(* TODO: filters: namespace[*] => min_level *)
+
+let rec add_writer_rec min_lvl writer parent_logger logger =
+  if parent_logger != logger then
+    begin
+      logger.min_lvl <- min min_lvl logger.min_lvl;
+      logger.writers <-
+        (match logger.writers with
+         | None -> Some writer
+         | Some writer' -> Some (writer' +++ writer));
+      add_writer_rec min_lvl writer logger logger.child;
+      add_writer_rec min_lvl writer parent_logger logger.sibling
+    end
+
+let[@inline] add_writer ~min_lvl writer =
+  add_writer_rec min_lvl writer root_logger root_logger.child
+
+module Pretty = struct
+  type t = {
+    mutex : Mutex.t;
+    bp : Buffer.t;
+    mutable align_to : int;
+    out : out_channel;
+  }
+
+  (* TODO: config timestamp *)
+  (* TODO: config color *)
+  (* TODO: config namespace *)
+
+  let header = function
+    | 0 -> "TRACE"
+    | 1 -> "DEBUG"
+    | 2 -> "INFO"
+    | 3 -> "WARN"
+    | _ -> "ERROR"
+
+  let ansi_color = function
+    | 0 -> 34
+    | 1 -> 36
+    | 2 -> 32
+    | 3 -> 33
+    | _ -> 31
+
+  let pr_timestamp bp ts =
+    let ts_ms = int_of_float (ts *. 1000.0) mod 1000 in
+    let tm = Unix.localtime ts in
+    Printf.bprintf bp "%04d-%02d-%02d %02d:%02d:%02d.%03d"
+      (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
+      tm.tm_hour tm.tm_min tm.tm_sec ts_ms
+
+  let pr_spaces bp n =
+    for _ = 1 to n do
+      Buffer.add_char bp ' '
+    done
+
+  let rec pr_lines_rec indent bp s i =
+    match String.index_from s i '\n' with
+    | exception Not_found ->
+      Buffer.add_substring bp s i (String.length s - i)
+    | k ->
+      Buffer.add_substring bp s i (k + 1 - i);
+      pr_spaces bp indent;
+      pr_lines_rec indent bp s (k + 1)
+
+  let pr_lines ~indent bp s =
+    pr_lines_rec indent bp s 0
+
+  let make (out : out_channel) = {
+    mutex = Mutex.create ();
+    bp = Buffer.create 512;
+    align_to = 0;
+    out;
+  }
+
+  let writer t ~ts ~ns ~lvl msg =
+    begin
+      Mutex.lock t.mutex;
+      Printf.bprintf t.bp "\x1b[1m%a\x1b[22m %s " pr_timestamp ts ns;
+      pr_spaces t.bp (t.align_to - Buffer.length t.bp);
+      t.align_to <- Buffer.length t.bp;
+      Printf.bprintf t.bp "\x1b[%dm%-5s\x1b[39;1m " (ansi_color lvl) (header lvl);
+      pr_lines t.bp msg ~indent:(t.align_to - 3);
+      Printf.bprintf t.bp "\x1b[0m\n";
+      Buffer.output_buffer t.out t.bp;
+      flush t.out;
+      Buffer.clear t.bp;
+      Mutex.unlock t.mutex
+    end
+end
+
+let init_pretty_writer ?min_level out =
+  Pretty.make out |>
+  Pretty.writer |>
+  add_writer ~min_lvl:(Option.fold ~some:lvl ~none:max_lvl min_level)
+

lib/logging/logging.mli

@@ -0,0 +1,29 @@
+type logger
+
+type level =
+  | TRACE
+  | DEBUG
+  | INFO
+  | WARN
+  | ERROR
+
+(* log_function (fun m -> m "<fmt>" <args>); *)
+type 'a log_function =
+  ((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
+
+module type Logs = sig
+  val logger : logger
+  val trace : _ log_function
+  val debug : _ log_function
+  val info  : _ log_function
+  val warn  : _ log_function
+  val error : _ log_function
+  val log   : level -> _ log_function
+end
+
+val logs : string -> (module Logs)
+val sublogs : logger -> string -> (module Logs)
+
+val init_pretty_writer :
+  ?min_level:level
+  -> out_channel -> unit

lib/server/connection.ml

@@ -3,6 +3,8 @@ open Result_syntax
 module User = Router.User
 module Chan = Router.Chan
 
+include (val Logging.sublogs logger "Connection")
+
 type t = {
   router : Router.t;
   addr : sockaddr;
@@ -206,7 +208,7 @@ let on_msg_join t name =
       | `chan -> Ok (Router.find_chan t.router name)
       | _     -> Error (nosuchchannel name)
     with Not_found ->
-      Logs.debug (fun m -> m "making new channel %S" name);
+      debug (fun m -> m "making new channel %S" name);
       let chan = Chan.make ~name in
       Chan.register chan ~router:t.router;
       (* TODO: make user +o *)
@@ -238,7 +240,7 @@ let on_msg_part t name =
   Router.relay msg ~from:me (`to_chan chan);
   Chan.part chan me;
   if Chan.no_members chan then begin
-    Logs.debug (fun m -> m "recycling channel %S" name);
+    debug (fun m -> m "recycling channel %S" name);
     Chan.unregister chan ~router:t.router;
   end;
   Ok ()
@@ -289,13 +291,13 @@ let split_command_params cmd params =
     [cmd, params]
 
 let pp_args ppf (cmd, params) =
-  Fmt.pf ppf "%s %a" cmd (Fmt.list (Fmt.fmt "%S") ~sep:Fmt.sp) params
+  Fmt.pf ppf "@[%s@ %a@]" cmd (Fmt.list (Fmt.fmt "%S") ~sep:Fmt.sp) params
 
 let on_msg t (msg : Irc.Msg.t) : unit =
   split_command_params msg.command msg.params |>
   List.iter
     (fun args ->
-       Logs.debug (fun m -> m "%a: %a" pp_sockaddr t.addr pp_args args);
+       debug (fun m -> m "@[%a:@ %a@]" pp_sockaddr t.addr pp_args args);
        match dispatch t args with
        | Ok () -> ()
        | Error err -> reply t err)

lib/server/dune

@@ -2,4 +2,5 @@
  (package talircd)
  (name server)
  (libraries
-   lwt lwt.unix lwt-dllist logs fmt irc))
+   lwt lwt.unix lwt-dllist fmt
+   logging irc))

lib/server/import.ml

@@ -19,3 +19,5 @@ module Result_syntax = struct
   let ( let* ) = Result.bind
   let ( let+ ) r f = Result.map f r
 end
+
+include (val Logging.logs "Irc")

lib/server/outbox.ml

@@ -1,5 +1,7 @@
 open! Import
 
+(* include (val Logging.sublogs logger "Outbox") *)
+
 type t = {
   stream : Irc.Msg.t Lwt_stream.t;
   push : Irc.Msg.t option -> unit;

lib/server/server.ml

@@ -2,6 +2,8 @@ open! Import
 open Lwt.Syntax
 open Lwt.Infix
 
+include (val Logging.sublogs logger "Server")
+
 let listener ~(port : int) ~(backlog : int) : (fd * sockaddr) Lwt_stream.t =
   let sock : fd Lwt.t =
     let fd = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
@@ -10,7 +12,7 @@ let listener ~(port : int) ~(backlog : int) : (fd * sockaddr) Lwt_stream.t =
     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;
-    Logs.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
   in
   let accept () = sock >>= Lwt_unix.accept >|= Option.some in
@@ -58,7 +60,7 @@ let writer (fd : fd) (obox : Irc.Msg.t Lwt_stream.t) : unit Lwt.t =
       | exn -> Lwt.fail exn)
 
 let handle_client (router : Router.t) (conn_fd : fd) (conn_addr : sockaddr) =
-  Logs.info (fun m -> m "new connection %a" pp_sockaddr conn_addr);
+  info (fun m -> m "new connection %a" pp_sockaddr conn_addr);
   let conn : Connection.t =
     Connection.make
       ~router
@@ -73,7 +75,7 @@ let handle_client (router : Router.t) (conn_fd : fd) (conn_addr : sockaddr) =
     (fun () -> writer)
     (fun () ->
        Lwt_unix.close conn_fd >|= fun () ->
-       Logs.info (fun m -> m "connection closed %a" pp_sockaddr conn_addr))
+       info (fun m -> m "connection closed %a" pp_sockaddr conn_addr))
 
 type config = {
   port : int;
@@ -89,7 +91,7 @@ let run (cfg : config) : unit Lwt.t =
     Lwt.on_failure
       (handle_client router fd adr)
       (fun exn ->
-         Logs.err (fun m -> m "%a: %a" pp_sockaddr adr Fmt.exn exn))
+         error (fun m -> m "%a: %a" pp_sockaddr adr Fmt.exn exn))
   in
 
   Lwt_stream.iter