From 31872eb1b13c1150b143cddc137a68d159f38838 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 23 Jan 2017 11:09:36 +0100 Subject: [PATCH] Shell: Improve `Logging` --- src/node_main.ml | 4 +- src/utils/logging.ml | 134 +++++++++++++++++++++++++++---- src/utils/logging.mli | 28 ++++++- test/lib/process.ml | 5 +- test/test_p2p_connection_pool.ml | 5 +- test/test_p2p_io_scheduler.ml | 2 +- 6 files changed, 150 insertions(+), 28 deletions(-) diff --git a/src/node_main.ml b/src/node_main.ml index f9a0543f8..a2c9f9701 100644 --- a/src/node_main.ml +++ b/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 -> diff --git a/src/utils/logging.ml b/src/utils/logging.ml index b41340dbf..fe791833d 100644 --- a/src/utils/logging.ml +++ b/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 diff --git a/src/utils/logging.mli b/src/utils/logging.mli index fb999b7b0..c366f11b9 100644 --- a/src/utils/logging.mli +++ b/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 diff --git a/test/lib/process.ml b/test/lib/process.ml index 2a60b2bbc..5a314237d 100644 --- a/test/lib/process.ml +++ b/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 ; diff --git a/test/test_p2p_connection_pool.ml b/test/test_p2p_connection_pool.ml index 1435f2ec9..f46541a47 100644 --- a/test/test_p2p_connection_pool.ml +++ b/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 .\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 _ -> () diff --git a/test/test_p2p_io_scheduler.ml b/test/test_p2p_io_scheduler.ml index e41fca204..0db147c3d 100644 --- a/test/test_p2p_io_scheduler.ml +++ b/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 () ->