diff --git a/src/lib_stdlib/logging.ml b/src/lib_stdlib/logging.ml index 7360afdc7..22655927f 100644 --- a/src/lib_stdlib/logging.ml +++ b/src/lib_stdlib/logging.ml @@ -24,11 +24,26 @@ type log_message = { tags : Tag.set ; } -let taps : (log_message -> unit) list ref = ref [] +type tap_id = int +let next_tap : int ref = ref 0 -let tap f = taps := f :: !taps +type tap = { + id : tap_id ; + process : log_message -> unit ; +} -let call_taps v = List.iter (fun f -> f v) !taps +let taps : tap list ref = ref [] + +let tap process = let id = !next_tap in + begin + next_tap := id + 1 ; + taps := { id ; process } :: !taps ; + id + end + +let untap x = taps := List.filter (fun tap -> tap.id <> x) !taps + +let call_taps v = List.iter (fun tap -> tap.process v) !taps module type SEMLOG = sig diff --git a/src/lib_stdlib/logging.mli b/src/lib_stdlib/logging.mli index ff1181f95..9e1f6df25 100644 --- a/src/lib_stdlib/logging.mli +++ b/src/lib_stdlib/logging.mli @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +(** Unique tag for a logging module. + Match against, e.g. `Logging.Core.Section`. *) type log_section = private .. type log_message = { @@ -15,7 +17,16 @@ type log_message = { tags : Tag.set ; } -val tap : (log_message -> unit) -> unit +type tap_id + +(** Intercept events as they are logged. All events will generate a call to + your tap function, but `text` will only be included for events that + actually print a message according to the active logging configuration. *) +val tap : (log_message -> unit) -> tap_id + +(** Remove a previously set tap by supplying its tap_id. Does nothing if + the tap was removed already. *) +val untap : tap_id -> unit type ('a,'b) msgf = (('a, Format.formatter, unit, 'b) format4 -> ?tags:Tag.set -> 'a) -> ?tags:Tag.set -> 'b type ('a,'b) log = ('a,'b) msgf -> 'b diff --git a/src/lib_stdlib/tag.mli b/src/lib_stdlib/tag.mli index e01f4de51..114f09d43 100644 --- a/src/lib_stdlib/tag.mli +++ b/src/lib_stdlib/tag.mli @@ -87,10 +87,30 @@ val map : (t -> t) -> set -> set val mapi : (t -> t) -> set -> set val pp_set : Format.formatter -> set -> unit +(** DSL for logging messages. Opening this locally makes it easy to supply a number + of semantic tags for a log event while using their values in the human-readable + text. For example: + + {[ + lwt_log_info Tag.DSL.(fun f -> + f "request for operations %a:%d from peer %a timed out." + -% t event "request_operations_timeout" + -% a Block_hash.Logging.tag bh + -% s operations_index_tag n + -% a P2p_peer.Id.Logging.tag pipeline.peer_id) + ]} *) module DSL : sig type (_,_,_,_) arg + + (** Use a semantic tag with a `%a` format, supplying the pretty printer from the tag. *) val a : 'v def -> 'v -> (('b -> 'v -> 'c) -> 'v -> 'd, 'b, 'c, 'd) arg + + (** Use a semantic tag with ordinary formats such as `%s`, `%d`, and `%f`. *) val s : 'v def -> 'v -> ('v -> 'd, 'b, 'c, 'd) arg + + (** Supply a semantic tag without formatting it. *) val t : 'v def -> 'v -> ('d, 'b, 'c, 'd) arg + + (** Perform the actual application of a tag to a format. *) val (-%) : (?tags:set -> 'a) -> ('a,Format.formatter,unit,'d) arg -> (?tags:set -> 'd) end