more logging tweaks

bin/main.ml

@@ -1,5 +1,5 @@
 Logging.init_pretty_writer stderr
-  ~min_level:DEBUG;
+  ~min_level:TRACE;
 
 Lwt_main.run
   (Server.run {

lib/logging/logging.ml

@@ -1,23 +1,16 @@
 type level =
-  | TRACE
-  | DEBUG
-  | INFO
-  | WARN
-  | ERROR
+  | TRACE (* 0 *)
+  | DEBUG (* 1 *)
+  | INFO  (* 2 *)
+  | WARN  (* 3 *)
+  | ERROR (* 4 *)
 
-let lvl = function
-  | TRACE -> 0
-  | DEBUG -> 1
-  | INFO  -> 2
-  | WARN  -> 3
-  | ERROR -> 4
-
-let max_lvl = 5
+external int_of_level : level -> int = "%identity"
 
 type writer =
   ts:float ->
   ns:string ->
-  lvl:int ->
+  lvl:level ->
   string ->
   unit
 
@@ -29,13 +22,13 @@ type logger = {
   namespace : string;
   mutable child : logger;
   sibling : logger;
-  mutable min_lvl : int;
+  mutable min_level : int;
   mutable writers : writer option;
 }
 
 let rec root_logger = {
   namespace = "";
-  min_lvl = 0;
+  min_level = 0;
   child = root_logger;
   sibling = root_logger;
   writers = None;
@@ -48,7 +41,7 @@ let make_logger parent_logger ns =
   in
   let rec logger = {
     namespace;
-    min_lvl = max_lvl;
+    min_level = Int.max_int;
     child = logger;
     sibling = parent_logger.child;
     writers = None;
@@ -64,8 +57,8 @@ let write logger lvl msg =
   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
+let[@inline] logf logger lvl : _ log_function = fun logk ->
+  if int_of_level lvl >= logger.min_level then
     logk (fun fmt ->
            Format.kasprintf (write logger lvl)
              ("@[<hov>" ^^ fmt))
@@ -84,12 +77,12 @@ 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
+    let[@inline] trace k = logf logger TRACE k
+    let[@inline] debug k = logf logger DEBUG k
+    let[@inline] info  k = logf logger INFO  k
+    let[@inline] warn  k = logf logger WARN  k
+    let[@inline] error k = logf logger ERROR k
+    let[@inline] log level k = logf logger level k
   end : Logs)
 
 let logs ns = make_logs root_logger ns
@@ -97,20 +90,20 @@ let sublogs logger ns = make_logs logger ns
 
 (* TODO: filters: namespace[*] => min_level *)
 
-let rec add_writer_rec min_lvl writer parent_logger logger =
+let rec add_writer_rec min_level writer parent_logger logger =
   if parent_logger != logger then
     begin
-      logger.min_lvl <- min min_lvl logger.min_lvl;
+      logger.min_level <- min min_level logger.min_level;
       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
+      add_writer_rec min_level writer logger logger.child;
+      add_writer_rec min_level writer parent_logger logger.sibling
     end
 
-let[@inline] add_writer ~min_lvl writer =
-  add_writer_rec min_lvl writer root_logger root_logger.child
+let[@inline] add_writer ?(min_level = WARN) writer =
+  add_writer_rec (int_of_level min_level) writer root_logger root_logger.child
 
 module Pretty = struct
   type t = {
@@ -125,18 +118,18 @@ module Pretty = struct
   (* TODO: config namespace *)
 
   let header = function
-    | 0 -> "TRACE"
-    | 1 -> "DEBUG"
-    | 2 -> "INFO"
-    | 3 -> "WARN"
-    | _ -> "ERROR"
+    | TRACE -> "TRACE"
+    | DEBUG -> "DEBUG"
+    | INFO  -> "INFO"
+    | WARN  -> "WARN"
+    | ERROR -> "ERROR"
 
   let ansi_color = function
-    | 0 -> 34
-    | 1 -> 36
-    | 2 -> 32
-    | 3 -> 33
-    | _ -> 31
+    | TRACE -> 34
+    | DEBUG -> 36
+    | INFO  -> 32
+    | WARN  -> 33
+    | ERROR -> 31
 
   let pr_timestamp bp ts =
     let ts_ms = int_of_float (ts *. 1000.0) mod 1000 in
@@ -172,10 +165,12 @@ module Pretty = struct
   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;
+      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);
+      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;
@@ -188,5 +183,4 @@ 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)
-
+  add_writer ?min_level

lib/server/connection.ml

@@ -298,7 +298,7 @@ let on_msg t (msg : Irc.Msg.t) : unit =
   split_command_params msg.command msg.params |>
   List.iter
     (fun args ->
-       debug (fun m -> m "@[%a:@ %a@]" pp_sockaddr t.addr pp_args args);
+       trace (fun m -> m "@[%a:@ %a@]" pp_sockaddr t.addr pp_args args);
        match dispatch t args with
        | Ok () -> ()
        | Error err -> reply t err)