From 7a3277e6251670d96097cbbbc942277ef7ff6ece Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 8 Feb 2018 10:51:01 +0100 Subject: [PATCH] Client refactor: Move part of `Logging` into `Logging_unix` --- src/bin_node/node_config_file.ml | 29 +++- src/bin_node/node_config_file.mli | 4 +- src/bin_node/node_run_command.ml | 4 +- src/bin_node/node_shared_arg.ml | 6 +- src/bin_node/node_shared_arg.mli | 2 +- src/lib_p2p/test/test_p2p_io_scheduler.ml | 2 +- src/lib_shell_services/worker_types.ml | 23 ++- src/lib_stdlib_lwt/logging.ml | 177 +++------------------- src/lib_stdlib_lwt/logging.mli | 23 +-- src/lib_stdlib_lwt/logging_unix.ml | 123 +++++++++++++++ src/lib_stdlib_lwt/logging_unix.mli | 27 ++++ 11 files changed, 228 insertions(+), 192 deletions(-) create mode 100644 src/lib_stdlib_lwt/logging_unix.ml create mode 100644 src/lib_stdlib_lwt/logging_unix.mli diff --git a/src/bin_node/node_config_file.ml b/src/bin_node/node_config_file.ml index 93fbef514..52aa37a37 100644 --- a/src/bin_node/node_config_file.ml +++ b/src/bin_node/node_config_file.ml @@ -46,7 +46,7 @@ and tls = { } and log = { - output : Logging.Output.t ; + output : Logging_unix.Output.t ; default_level : Logging.level ; rules : string option ; template : Logging.template ; @@ -274,6 +274,27 @@ let rpc : rpc Data_encoding.t = (opt "crt" string) (opt "key" string)) +let level_encoding = + let open Logging in + 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 + let log = let open Data_encoding in conv @@ -282,8 +303,8 @@ let log = (fun (output, default_level, rules, template) -> { output ; default_level ; rules ; template }) (obj4 - (dft "output" Logging.Output.encoding default_log.output) - (dft "level" Logging.level_encoding default_log.default_level) + (dft "output" Logging_unix.Output.encoding default_log.output) + (dft "level" level_encoding default_log.default_level) (opt "rules" string) (dft "template" string default_log.template)) @@ -301,7 +322,7 @@ let worker_limits_encoding { backlog_size ; backlog_level ; zombie_lifetime ; zombie_memory }) (obj4 (dft "worker_backlog_size" uint16 default_size) - (dft "worker_backlog_level" Logging.level_encoding default_level) + (dft "worker_backlog_level" level_encoding default_level) (dft "worker_zombie_lifetime" float default_zombie_lifetime) (dft "worker_zombie_memory" float default_zombie_memory)) diff --git a/src/bin_node/node_config_file.mli b/src/bin_node/node_config_file.mli index d9f05d70e..f296ef761 100644 --- a/src/bin_node/node_config_file.mli +++ b/src/bin_node/node_config_file.mli @@ -36,7 +36,7 @@ and tls = { } and log = { - output : Logging.Output.t ; + output : Logging_unix.Output.t ; default_level : Logging.level ; rules : string option ; template : Logging.template ; @@ -72,7 +72,7 @@ val update: ?cors_origins:string list -> ?cors_headers:string list -> ?rpc_tls:tls -> - ?log_output:Logging.Output.t -> + ?log_output:Logging_unix.Output.t -> ?bootstrap_threshold:int -> t -> t tzresult Lwt.t diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index 7c1cd6e02..22caf3542 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -88,7 +88,7 @@ let init_logger ?verbosity (log_config : Node_config_file.log) = exit 1 end end ; - Logging.init ~template:log_config.template log_config.output + Logging_unix.init ~template:log_config.template log_config.output let init_node ?sandbox (config : Node_config_file.t) = let patch_context json ctxt = @@ -243,7 +243,7 @@ let run ?verbosity ?sandbox (config : Node_config_file.t) = lwt_log_notice "Shutting down the RPC server..." >>= fun () -> Lwt_utils.may ~f:RPC_server.shutdown rpc >>= fun () -> lwt_log_notice "BYE (%d)" x >>= fun () -> - Logging.close () >>= fun () -> + Logging_unix.close () >>= fun () -> return () let process sandbox verbosity args = diff --git a/src/bin_node/node_shared_arg.ml b/src/bin_node/node_shared_arg.ml index eb0206d13..6c5c3867b 100644 --- a/src/bin_node/node_shared_arg.ml +++ b/src/bin_node/node_shared_arg.ml @@ -31,7 +31,7 @@ type t = { cors_origins: string list ; cors_headers: string list ; rpc_tls: Node_config_file.tls option ; - log_output: Logging.Output.t option ; + log_output: Logging_unix.Output.t option ; bootstrap_threshold: int option ; } @@ -106,10 +106,10 @@ end module Term = struct let log_output_converter = - (fun s -> match Logging.Output.of_string s with + (fun s -> match Logging_unix.Output.of_string s with | Some res -> `Ok res | None -> `Error s), - Logging.Output.pp + Logging_unix.Output.pp (* misc args *) diff --git a/src/bin_node/node_shared_arg.mli b/src/bin_node/node_shared_arg.mli index e076dea84..b5f2f0322 100644 --- a/src/bin_node/node_shared_arg.mli +++ b/src/bin_node/node_shared_arg.mli @@ -26,7 +26,7 @@ type t = { cors_origins: string list ; cors_headers: string list ; rpc_tls: Node_config_file.tls option ; - log_output: Logging.Output.t option ; + log_output: Logging_unix.Output.t option ; bootstrap_threshold: int option ; } diff --git a/src/lib_p2p/test/test_p2p_io_scheduler.ml b/src/lib_p2p/test/test_p2p_io_scheduler.ml index d0d5299fe..b637560c8 100644 --- a/src/lib_p2p/test/test_p2p_io_scheduler.ml +++ b/src/lib_p2p/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 >>= fun () -> + Logging_unix.init Stderr >>= fun () -> listen ?port addr >>= fun (main_socket, port) -> Process.detach ~prefix:"server: " begin fun _ -> server diff --git a/src/lib_shell_services/worker_types.ml b/src/lib_shell_services/worker_types.ml index 7d43fe8ad..a178d98c6 100644 --- a/src/lib_shell_services/worker_types.ml +++ b/src/lib_shell_services/worker_types.ml @@ -7,6 +7,27 @@ (* *) (**************************************************************************) +let level_encoding = + let open Logging in + 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 + type limits = { backlog_size : int ; backlog_level : Logging.level ; @@ -90,7 +111,7 @@ let full_status_encoding req_encoding evt_encoding error_encoding = let events_encoding = list (obj2 - (req "level" Logging.level_encoding) + (req "level" level_encoding) (req "events" (dynamic_size (list (dynamic_size evt_encoding))))) in let current_request_encoding = obj3 diff --git a/src/lib_stdlib_lwt/logging.ml b/src/lib_stdlib_lwt/logging.ml index b7d72f76e..5b567b290 100644 --- a/src/lib_stdlib_lwt/logging.ml +++ b/src/lib_stdlib_lwt/logging.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Lwt.Infix - module type LOG = sig val debug: ('a, Format.formatter, unit, unit) format4 -> 'a @@ -28,21 +26,21 @@ module type LOG = sig end let log_f - ?exn ?(section = Lwt_log.Section.main) ?location ?logger ~level format = - if level < Lwt_log.Section.level section then + ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format = + if level < Lwt_log_core.Section.level section then Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format else Format.kasprintf - (fun msg -> Lwt_log.log ?exn ~section ?location ?logger ~level msg) + (fun msg -> Lwt_log_core.log ?exn ~section ?location ?logger ~level msg) format let ign_log_f - ?exn ?(section = Lwt_log.Section.main) ?location ?logger ~level format = - if level < Lwt_log.Section.level section then + ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format = + if level < Lwt_log_core.Section.level section then Format.ikfprintf (fun _ -> ()) Format.std_formatter format else Format.kasprintf - (fun msg -> Lwt_log.ign_log ?exn ~section ?location ?logger ~level msg) + (fun msg -> Lwt_log_core.ign_log ?exn ~section ?location ?logger ~level msg) format let sections = ref [] @@ -50,21 +48,21 @@ let sections = ref [] module Make(S : sig val name: string end) : LOG = struct let () = sections := S.name :: !sections - let section = Lwt_log.Section.make S.name + let section = Lwt_log_core.Section.make S.name - let debug fmt = ign_log_f ~section ~level:Lwt_log.Debug fmt - let log_info fmt = ign_log_f ~section ~level:Lwt_log.Info fmt - let log_notice fmt = ign_log_f ~section ~level:Lwt_log.Notice fmt - let warn fmt = ign_log_f ~section ~level:Lwt_log.Warning fmt - let log_error fmt = ign_log_f ~section ~level:Lwt_log.Error fmt - let fatal_error fmt = ign_log_f ~section ~level:Lwt_log.Fatal fmt + let debug fmt = ign_log_f ~section ~level:Lwt_log_core.Debug fmt + let log_info fmt = ign_log_f ~section ~level:Lwt_log_core.Info fmt + let log_notice fmt = ign_log_f ~section ~level:Lwt_log_core.Notice fmt + let warn fmt = ign_log_f ~section ~level:Lwt_log_core.Warning fmt + let log_error fmt = ign_log_f ~section ~level:Lwt_log_core.Error fmt + let fatal_error fmt = ign_log_f ~section ~level:Lwt_log_core.Fatal fmt - let lwt_debug fmt = log_f ~section ~level:Lwt_log.Debug fmt - let lwt_log_info fmt = log_f ~section ~level:Lwt_log.Info fmt - let lwt_log_notice fmt = log_f ~section ~level:Lwt_log.Notice fmt - let lwt_warn fmt = log_f ~section ~level:Lwt_log.Warning fmt - let lwt_log_error fmt = log_f ~section ~level:Lwt_log.Error fmt - let lwt_fatal_error fmt = log_f ~section ~level:Lwt_log.Fatal fmt + let lwt_debug fmt = log_f ~section ~level:Lwt_log_core.Debug fmt + let lwt_log_info fmt = log_f ~section ~level:Lwt_log_core.Info fmt + let lwt_log_notice fmt = log_f ~section ~level:Lwt_log_core.Notice fmt + let lwt_warn fmt = log_f ~section ~level:Lwt_log_core.Warning fmt + let lwt_log_error fmt = log_f ~section ~level:Lwt_log_core.Error fmt + let lwt_fatal_error fmt = log_f ~section ~level:Lwt_log_core.Fatal fmt end @@ -89,122 +87,6 @@ module Client = struct module Denunciation = Make(struct let name = "client.denunciation" end) end -type template = Lwt_log.template -let default_template = "$(date) - $(section): $(message)" - -module Output = struct - - type t = - | Null - | Stdout - | Stderr - | File of string - | Syslog of Lwt_log.syslog_facility - - let to_string : t -> string = 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" - - let of_string : string -> t = 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 - - let encoding = - let open Data_encoding in - conv to_string of_string string - - let of_string str = - try - Some (Data_encoding.Json.destruct encoding (`String str)) - with _ -> None - - let to_string output = - match Data_encoding.Json.construct encoding output with - | `String res -> res - | #Data_encoding.json -> assert false - - let pp fmt output = - Format.fprintf fmt "%s" (to_string output) -end - -let init ?(template = default_template) output = - let open Output in - begin - match output with - | Stderr -> - 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_log.file ~file_name ~template () - | Null -> - Lwt.return @@ - Lwt_log.null - | Syslog facility -> - Lwt.return @@ - Lwt_log.syslog ~template ~facility () - end >>= fun logger -> - Lwt_log.default := logger ; - Lwt.return_unit - -let close () = - Lwt_log.close !Lwt_log.default - type level = Lwt_log_core.level = | Debug (** Debugging message. They can be automatically removed by the @@ -221,22 +103,5 @@ type level = Lwt_log_core.level = 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 +type template = Lwt_log_core.template +let default_template = "$(date) - $(section): $(message)" diff --git a/src/lib_stdlib_lwt/logging.mli b/src/lib_stdlib_lwt/logging.mli index a22c6982c..5db0dc04d 100644 --- a/src/lib_stdlib_lwt/logging.mli +++ b/src/lib_stdlib_lwt/logging.mli @@ -67,25 +67,4 @@ type level = Lwt_log_core.level = type template = Lwt_log.template val default_template : template -val level_encoding : level Data_encoding.t - -module Output : sig - type t = - | Null - | Stdout - | Stderr - | File of string - | Syslog of Lwt_log.syslog_facility - - val encoding : t Data_encoding.t - val of_string : string -> t option - val to_string : t -> string - val pp : Format.formatter -> t -> unit -end - - -val init: ?template:template -> Output.t -> unit Lwt.t - -val close: unit -> unit Lwt.t - -val sections : string list ref +val sections: string list ref diff --git a/src/lib_stdlib_lwt/logging_unix.ml b/src/lib_stdlib_lwt/logging_unix.ml new file mode 100644 index 000000000..d545393b7 --- /dev/null +++ b/src/lib_stdlib_lwt/logging_unix.ml @@ -0,0 +1,123 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Lwt.Infix + +module Output = struct + + type t = + | Null + | Stdout + | Stderr + | File of string + | Syslog of Lwt_log.syslog_facility + + let to_string : t -> string = 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" + + let of_string : string -> t = 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 + + let encoding = + let open Data_encoding in + conv to_string of_string string + + let of_string str = + try + Some (Data_encoding.Json.destruct encoding (`String str)) + with _ -> None + + let to_string output = + match Data_encoding.Json.construct encoding output with + | `String res -> res + | #Data_encoding.json -> assert false + + let pp fmt output = + Format.fprintf fmt "%s" (to_string output) +end + +let init ?(template = Logging.default_template) output = + let open Output in + begin + match output with + | Stderr -> + 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_log.file ~file_name ~template () + | Null -> + Lwt.return @@ + Lwt_log.null + | Syslog facility -> + Lwt.return @@ + Lwt_log.syslog ~template ~facility () + end >>= fun logger -> + Lwt_log.default := logger ; + Lwt.return_unit + +let close () = + Lwt_log.close !Lwt_log.default diff --git a/src/lib_stdlib_lwt/logging_unix.mli b/src/lib_stdlib_lwt/logging_unix.mli new file mode 100644 index 000000000..6a4677450 --- /dev/null +++ b/src/lib_stdlib_lwt/logging_unix.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Output : sig + type t = + | Null + | Stdout + | Stderr + | File of string + | Syslog of Lwt_log.syslog_facility + + val encoding : t Data_encoding.t + val of_string : string -> t option + val to_string : t -> string + val pp : Format.formatter -> t -> unit +end + + +val init: ?template:Logging.template -> Output.t -> unit Lwt.t + +val close: unit -> unit Lwt.t