112 lines
2.8 KiB
OCaml
112 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
|
|
|
|
let should_upgrade_to_journald = Journald.should_upgrade
|