From 02ea1e199a5a7e1cae4d488a788178e7be178a7d Mon Sep 17 00:00:00 2001 From: Joseph Thomas Date: Tue, 2 Nov 2021 18:55:38 -0600 Subject: [PATCH 1/2] Allow log levels to be configured per-source. --- src/dream.mli | 12 +++++++++-- src/middleware/log.ml | 47 ++++++++++++++++++++++++++++++++++--------- 2 files changed, 47 insertions(+), 12 deletions(-) diff --git a/src/dream.mli b/src/dream.mli index fa1a9ed8..010f82f0 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -1688,7 +1688,8 @@ type sub_log = { } (** Sub-logs. See {!Dream.val-sub_log} right below. *) -val sub_log : string -> sub_log + +val sub_log : ?level:[< log_level] -> string -> sub_log (** Creates a new sub-log with the given name. For example, {[ @@ -1702,6 +1703,10 @@ val sub_log : string -> sub_log log.error (fun log -> log ~request "Validation failed") ]} + - [?level] sets the log level threshold for this sub-log only. + If not provided, falls back to the last value configured by `set_log_level` + for the logger name, or to the global log level if that is undefined. + See [README] of example {{:https://github.com/aantron/dream/tree/master/example/a-log#files} [a-log]}. *) @@ -1730,13 +1735,16 @@ val initialize_log : [Lwt.async_exception_hook]} so as to forward all asynchronous exceptions to the logger, and not terminate the process. - - [~level] sets the log level threshould for the entire binary. The default + - [~level] sets the log level threshold for the entire binary. The default is [`Info]. - [~enable:false] disables Dream logging completely. This can help sanitize output during testing. *) +val set_log_level : string -> [< log_level ] -> unit +(** Configure the sub-log with the input name to use a specific log threshold. *) + (** {1 Errors} diff --git a/src/middleware/log.ml b/src/middleware/log.ml index 75cd049e..4c43e7cd 100644 --- a/src/middleware/log.ml +++ b/src/middleware/log.ml @@ -197,6 +197,12 @@ let enable = let level = ref Logs.Info +let custom_log_levels : (string * Logs.level) list ref = + ref [] + +let sources : (string * Logs.src) list ref = + ref [] + let set_printexc = ref true @@ -212,6 +218,14 @@ type log_level = [ | `Debug ] +let to_logs_level l = + match l with + | `Error -> Logs.Error + | `Warning -> Logs.Warning + | `Info -> Logs.Info + | `Debug -> Logs.Debug + + exception Logs_are_not_initialized let setup_logs = @@ -244,13 +258,14 @@ type sub_log = { debug : 'a. ('a, unit) conditional_log; } -let sub_log name = +let sub_log ?level:level_ name = (* This creates a wrapper, as described above. The wrapper forwards to a logger of the Logs library, but instead of passing the formatter m to the user's callback, it passes a formatter m', which is like m, but lacks a ?tags argument. It has a ?request argument instead. If ~request is given, m' immediately tries to retrieve the request id, put it into a Logs tag, and call Logs' m with the user's formatting arguments and the tag. *) + let forward ~(destination_log : _ Logs.log) user's_k = let `Initialized = initialized () in @@ -268,10 +283,19 @@ let sub_log name = log ~tags format_and_arguments)) in + let level = List.find Option.is_some [ + Option.map to_logs_level level_; + List.assoc_opt name !custom_log_levels; + Some !level + ] in + (* Create the actual Logs source, and then wrap all the interesting functions. *) - let (module Log) = Logs.src_log (Logs.Src.create name) in - + let src = Logs.Src.create name in + let (module Log) = Logs.src_log src in + Logs.Src.set_level src level; + custom_log_levels := (name, Option.get level) :: List.remove_assoc name !custom_log_levels; + sources := (name, src) :: (List.remove_assoc name !sources); { error = (fun k -> forward ~destination_log:Log.err k); warning = (fun k -> forward ~destination_log:Log.warn k); @@ -319,6 +343,7 @@ let set_up_exception_hook () = |> iter_backtrace (fun line -> log.error (fun log -> log "%s" line)) end + let initialize_log ?(backtraces = true) ?(async_exception_hook = true) @@ -335,19 +360,21 @@ let initialize_log set_async_exception_hook := false; let level_ = - match level_ with - | None -> Logs.Info - | Some `Error -> Logs.Error - | Some `Warning -> Logs.Warning - | Some `Info -> Logs.Info - | Some `Debug -> Logs.Debug - in + Option.map to_logs_level level_ + |> Option.value ~default:Logs.Info in enable := enable_; level := level_; let `Initialized = initialized () in () +let set_log_level name level = + let level = to_logs_level level in + custom_log_levels := (name, level) :: (List.remove_assoc name !custom_log_levels); + let src = List.assoc_opt name !sources in + Option.iter (fun s -> Logs.Src.set_level s (Some level)) src + + module Make (Pclock : Mirage_clock.PCLOCK) = struct let now () = From fe2a9512fa5a8d59c3f18e9c4fe6bdefa04c27dc Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Mon, 8 Nov 2021 14:42:43 +0300 Subject: [PATCH 2/2] Tweaks --- src/dream.mli | 11 +++++------ src/middleware/log.ml | 14 +++++++------- 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src/dream.mli b/src/dream.mli index 010f82f0..79de562d 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -1688,7 +1688,6 @@ type sub_log = { } (** Sub-logs. See {!Dream.val-sub_log} right below. *) - val sub_log : ?level:[< log_level] -> string -> sub_log (** Creates a new sub-log with the given name. For example, @@ -1703,9 +1702,9 @@ val sub_log : ?level:[< log_level] -> string -> sub_log log.error (fun log -> log ~request "Validation failed") ]} - - [?level] sets the log level threshold for this sub-log only. - If not provided, falls back to the last value configured by `set_log_level` - for the logger name, or to the global log level if that is undefined. + [?level] sets the log level threshold for this sub-log only. If not + provided, falls back to the global log level set by {!Dream.initialize_log}, + unless {!Dream.set_log_level} is used. See [README] of example {{:https://github.com/aantron/dream/tree/master/example/a-log#files} @@ -1741,9 +1740,9 @@ val initialize_log : - [~enable:false] disables Dream logging completely. This can help sanitize output during testing. *) - val set_log_level : string -> [< log_level ] -> unit -(** Configure the sub-log with the input name to use a specific log threshold. *) +(** Set the log level threshold of the given sub-log. *) + (** {1 Errors} diff --git a/src/middleware/log.ml b/src/middleware/log.ml index 4c43e7cd..53be550d 100644 --- a/src/middleware/log.ml +++ b/src/middleware/log.ml @@ -225,7 +225,6 @@ let to_logs_level l = | `Info -> Logs.Info | `Debug -> Logs.Debug - exception Logs_are_not_initialized let setup_logs = @@ -265,7 +264,6 @@ let sub_log ?level:level_ name = ?tags argument. It has a ?request argument instead. If ~request is given, m' immediately tries to retrieve the request id, put it into a Logs tag, and call Logs' m with the user's formatting arguments and the tag. *) - let forward ~(destination_log : _ Logs.log) user's_k = let `Initialized = initialized () in @@ -283,7 +281,8 @@ let sub_log ?level:level_ name = log ~tags format_and_arguments)) in - let level = List.find Option.is_some [ + let level = + List.find Option.is_some [ Option.map to_logs_level level_; List.assoc_opt name !custom_log_levels; Some !level @@ -294,8 +293,10 @@ let sub_log ?level:level_ name = let src = Logs.Src.create name in let (module Log) = Logs.src_log src in Logs.Src.set_level src level; - custom_log_levels := (name, Option.get level) :: List.remove_assoc name !custom_log_levels; + custom_log_levels := + (name, Option.get level)::(List.remove_assoc name !custom_log_levels); sources := (name, src) :: (List.remove_assoc name !sources); + { error = (fun k -> forward ~destination_log:Log.err k); warning = (fun k -> forward ~destination_log:Log.warn k); @@ -343,7 +344,6 @@ let set_up_exception_hook () = |> iter_backtrace (fun line -> log.error (fun log -> log "%s" line)) end - let initialize_log ?(backtraces = true) ?(async_exception_hook = true) @@ -370,11 +370,11 @@ let initialize_log let set_log_level name level = let level = to_logs_level level in - custom_log_levels := (name, level) :: (List.remove_assoc name !custom_log_levels); + custom_log_levels := + (name, level)::(List.remove_assoc name !custom_log_levels); let src = List.assoc_opt name !sources in Option.iter (fun s -> Logs.Src.set_level s (Some level)) src - module Make (Pclock : Mirage_clock.PCLOCK) = struct let now () =