talircd/lib/logging/logging.ml

110 lines
2.8 KiB
OCaml

include Core
type logger = {
namespace : string;
mutable child : logger;
sibling : logger;
mutable min_level : int;
mutable writers : writer option;
}
let rec root_logger = {
namespace = "";
min_level = 0;
child = root_logger;
sibling = root_logger;
writers = None;
}
let make_logger parent_logger ns =
let namespace =
if parent_logger == root_logger then ns
else String.concat "." [parent_logger.namespace; ns];
in
let rec logger = {
namespace;
min_level = Int.max_int;
child = logger;
sibling = parent_logger.child;
writers = None;
} in
parent_logger.child <- logger;
logger
type 'a log_function =
((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
let write logger lvl msg =
let ts = Time.stamp () in
let ns = logger.namespace in
Option.iter (fun w -> w ~ts ~ns ~lvl msg) logger.writers
let[@inline] logf logger lvl : _ log_function = fun logk ->
if int_of_level lvl >= logger.min_level then
logk (fun fmt ->
Format.kasprintf (write logger lvl)
("@[<hov>" ^^ fmt))
module type Logs = sig
val logger : logger
val trace : _ log_function
val debug : _ log_function
val info : _ log_function
val warn : _ log_function
val error : _ log_function
val log : level -> _ log_function
end
let make_logs parent_logger ns =
(module struct
let logger = make_logger parent_logger ns
let[@inline] trace k = logf logger TRACE k
let[@inline] debug k = logf logger DEBUG k
let[@inline] info k = logf logger INFO k
let[@inline] warn k = logf logger WARN k
let[@inline] error k = logf logger ERROR k
let[@inline] log level k = logf logger level k
end : Logs)
let logs ns = make_logs root_logger ns
let sublogs logger ns = make_logs logger ns
(* TODO: filters: namespace[*] => min_level *)
let rec add_writer_rec min_level writer parent_logger logger =
if parent_logger != logger then
begin
logger.min_level <- min min_level logger.min_level;
logger.writers <-
(match logger.writers with
| None -> Some writer
| Some writer' -> Some (writer' +++ writer));
add_writer_rec min_level writer logger logger.child;
add_writer_rec min_level writer parent_logger logger.sibling
end
let[@inline] add_writer ?(min_level = WARN) writer =
add_writer_rec (int_of_level min_level) writer root_logger root_logger.child
let init_pretty_writer
?min_level
?(color = true)
?(timestamp = true)
?(namespace = true)
?(level = true)
out
=
Pretty.make out { color; timestamp; namespace; level } |>
Pretty.writer |>
add_writer ?min_level
let init_journald_writer
?min_level
?path
()
=
Journald.make () ?path |>
Journald.writer |>
add_writer ?min_level