Shell: Improve Logging

src/node_main.ml

@@ -411,7 +411,7 @@ let init_logger { log_output ; log_level } =
   | `Stderr -> Logging.init Stderr
   | `File fp -> Logging.init (File fp)
   | `Null -> Logging.init Null
-  | `Syslog -> Logging.init Syslog
+  | `Syslog -> Logging.init (Syslog `Local1)
 
 let init_node
     { sandbox ; sandbox_param ;
@@ -533,7 +533,7 @@ let init_signal () =
 let main cfg =
   Random.self_init () ;
   Sodium.Random.stir () ;
-  init_logger cfg;
+  init_logger cfg >>= fun () ->
   Updater.init cfg.protocol;
   lwt_log_notice "Starting the Tezos node..." >>= fun () ->
   init_node cfg >>=? fun node ->

src/utils/logging.ml

@@ -7,6 +7,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open Lwt.Infix
+
 module type LOG = sig
 
   val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
@@ -86,32 +88,134 @@ module Client = struct
 end
 module Webclient = Make(struct let name = "webclient" end)
 
-let template = "$(date) $(name)[$(pid)]: $(message)"
-
-let default_logger () =
-  Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
+type template = Lwt_log.template
+let default_template = "$(date) - $(section): $(message)"
 
 type kind =
   | Null
   | Stdout
   | Stderr
   | File of string
-  | Syslog
-  | Manual of Lwt_log.logger
+  | Syslog of Lwt_log.syslog_facility
 
-let init kind =
-  let logger =
+let kind_encoding =
+  let open Data_encoding in
+  conv
+    (function
+      | Null -> "/dev/null"
+      | Stdout -> "stdout"
+      | Stderr -> "stderr"
+      | File fp -> fp
+      | Syslog `Auth -> "syslog:auth"
+      | Syslog `Authpriv -> "syslog:authpriv"
+      | Syslog `Cron -> "syslog:cron"
+      | Syslog `Daemon -> "syslog:daemon"
+      | Syslog `FTP -> "syslog:ftp"
+      | Syslog `Kernel -> "syslog:kernel"
+      | Syslog `Local0 -> "syslog:local0"
+      | Syslog `Local1 -> "syslog:local1"
+      | Syslog `Local2 -> "syslog:local2"
+      | Syslog `Local3 -> "syslog:local3"
+      | Syslog `Local4 -> "syslog:local4"
+      | Syslog `Local5 -> "syslog:local5"
+      | Syslog `Local6 -> "syslog:local6"
+      | Syslog `Local7 -> "syslog:local7"
+      | Syslog `LPR -> "syslog:lpr"
+      | Syslog `Mail -> "syslog:mail"
+      | Syslog `News -> "syslog:news"
+      | Syslog `Syslog -> "syslog:syslog"
+      | Syslog `User -> "syslog:user"
+      | Syslog `UUCP -> "syslog:uucp"
+      | Syslog `NTP -> "syslog:ntp"
+      | Syslog `Security -> "syslog:security"
+      | Syslog `Console -> "syslog:console")
+    (function
+      | "/dev/null" | "null" -> Null
+      | "stdout" -> Stdout
+      | "stderr" -> Stderr
+      | "syslog:auth" -> Syslog `Auth
+      | "syslog:authpriv" -> Syslog `Authpriv
+      | "syslog:cron" -> Syslog `Cron
+      | "syslog:daemon" -> Syslog `Daemon
+      | "syslog:ftp" -> Syslog `FTP
+      | "syslog:kernel" -> Syslog `Kernel
+      | "syslog:local0" -> Syslog `Local0
+      | "syslog:local1" -> Syslog `Local1
+      | "syslog:local2" -> Syslog `Local2
+      | "syslog:local3" -> Syslog `Local3
+      | "syslog:local4" -> Syslog `Local4
+      | "syslog:local5" -> Syslog `Local5
+      | "syslog:local6" -> Syslog `Local6
+      | "syslog:local7" -> Syslog `Local7
+      | "syslog:lpr" -> Syslog `LPR
+      | "syslog:mail" -> Syslog `Mail
+      | "syslog:news" -> Syslog `News
+      | "syslog:syslog" -> Syslog `Syslog
+      | "syslog:user" -> Syslog `User
+      | "syslog:uucp" -> Syslog `UUCP
+      | "syslog:ntp" -> Syslog `NTP
+      | "syslog:security" -> Syslog `Security
+      | "syslog:console" -> Syslog `Console
+      (* | s when start_with "syslog:" FIXME error or warning. *)
+      | fp ->
+          (* TODO check absolute path *)
+          File fp)
+    string
+
+
+let init ?(template = default_template) kind =
+  begin
     match kind with
     | Stderr ->
-        default_logger ()
+        Lwt.return @@
+        Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
     | Stdout ->
+        Lwt.return @@
         Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout ()
     | File file_name ->
-        Lwt_main.run (Lwt_log.file ~file_name ~template ())
+        Lwt_log.file ~file_name ~template ()
     | Null ->
+        Lwt.return @@
         Lwt_log.null
-    | Syslog ->
-        Printf.eprintf "Warning: log_kind \"syslog\" not yet implemented.\n%!";
-        default_logger ()
-    | Manual logger -> logger in
-  Lwt_log.default := logger
+    | Syslog facility ->
+        Lwt.return @@
+        Lwt_log.syslog ~template ~facility ()
+  end >>= fun logger ->
+  Lwt_log.default := logger ;
+  Lwt.return_unit
+
+type level = Lwt_log_core.level =
+  | Debug
+      (** Debugging message. They can be automatically removed by the
+          syntax extension. *)
+  | Info
+      (** Informational message. Suitable to be displayed when the
+          program is in verbose mode. *)
+  | Notice
+      (** Same as {!Info}, but is displayed by default. *)
+  | Warning
+      (** Something strange happend *)
+  | Error
+      (** An error message, which should not means the end of the
+          program. *)
+  | Fatal
+
+let level_encoding =
+  let open Data_encoding in
+  conv
+    (function
+      | Fatal -> "fatal"
+      | Error -> "error"
+      | Warning -> "warning"
+      | Notice -> "notice"
+      | Info -> "info"
+      | Debug -> "debug")
+    (function
+      | "error" -> Error
+      | "warn" -> Warning
+      | "notice" -> Notice
+      | "info" -> Info
+      | "debug" -> Debug
+      | "fatal" -> Fatal
+      | _ -> invalid_arg "Logging.level")
+    string

src/utils/logging.mli

@@ -48,12 +48,34 @@ module Webclient : LOG
 
 module Make(S: sig val name: string end) : LOG
 
+type level = Lwt_log_core.level =
+  | Debug
+      (** Debugging message. They can be automatically removed by the
+          syntax extension. *)
+  | Info
+      (** Informational message. Suitable to be displayed when the
+          program is in verbose mode. *)
+  | Notice
+      (** Same as {!Info}, but is displayed by default. *)
+  | Warning
+      (** Something strange happend *)
+  | Error
+      (** An error message, which should not means the end of the
+          program. *)
+  | Fatal
+
+type template = Lwt_log.template
+val default_template : template
+
+val level_encoding : level Data_encoding.t
+
 type kind =
   | Null
   | Stdout
   | Stderr
   | File of string
-  | Syslog
-  | Manual of Lwt_log.logger
+  | Syslog of Lwt_log.syslog_facility
 
-val init: kind -> unit
+val kind_encoding : kind Data_encoding.t
+
+val init: ?template:template -> kind -> unit Lwt.t

test/lib/process.ml

@@ -19,11 +19,8 @@ let detach ?(prefix = "") f =
   | 0 ->
       Random.self_init () ;
       let template = Format.asprintf "%s$(section): $(message)" prefix in
-      let logger =
-        Lwt_log.channel
-          ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () in
-      Logging.init (Manual logger) ;
       Lwt_main.run begin
+        Logging.init ~template Stderr >>= fun () ->
         lwt_log_notice "PID: %d" (Unix.getpid ()) >>= fun () ->
         f ()
       end ;

test/test_p2p_connection_pool.ml

@@ -182,6 +182,7 @@ let spec = Arg.[
 
 let main () =
   let open Utils in
+  Logging.init Stderr >>= fun () ->
   let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
   let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
   Arg.parse spec anon_fun usage_msg ;
@@ -191,7 +192,5 @@ let main () =
 
 let () =
   Sys.catch_break true ;
-  try
-    Logging.init Stderr ;
-    Lwt_main.run @@ main ()
+  try Lwt_main.run @@ main ()
   with _ -> ()

test/test_p2p_io_scheduler.ml

@@ -140,7 +140,7 @@ let run
     ?max_download_speed ?max_upload_speed
     ~read_buffer_size ?read_queue_size ?write_queue_size
     addr port time n =
-  Logging.init Stderr ;
+  Logging.init Stderr >>= fun () ->
   listen ?port addr >>= fun (main_socket, port) ->
   let server =
     Process.detach ~prefix:"server " begin fun () ->