haskal
/
xlog
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

bikeshed source location and exceptions

This commit is contained in:
xenia 2024-04-23 01:39:03 -04:00
parent 667bd757de
commit d605351f55
7 changed files with 166 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
README.md
View File

@ -11,12 +11,38 @@ same license
```ocaml
include (val Xlog.logs __FUNCTION__)
(* basic usage *)
let () =
info (fun m -> m "meow meow meow")
(* add source location info *)
let () =
info ~__POS__ ~__FUNCTION__ (fun m -> m "meow meow meow")
(* log exception *)
try
fallible_task ()
with
| e ->
exn e (Printexc.get_raw_backtrace ()) ~__POS__ ~__FUNCTION__
(fun m -> m "encountered error")
module Submodule = struct
include (val Xlog.logs __FUNCTION__)
(* ... *)
end
(* in the main module *)
Xlog.init_pretty_writer stdout
~min_level:Xlog.DEBUG
(* other options *)
(* if running as a daemon *)
if Xlog.should_upgrade_to_journald () then
Xlog.init_journald_writer ()
~min_level:Xlog.DEBUG
else
Xlog.init_pretty_writer stdout
~min_level:Xlog.DEBUG
```

11
lib/core.ml
View File

@ -10,10 +10,15 @@ external int_of_level : level -> int = "%identity"
type writer =
ts:Time.t ->
ns:string ->
filename:string ->
lineno:int ->
func:string ->
errno:int ->
exn:((exn * Printexc.raw_backtrace) option) ->
lvl:level ->
string ->
unit
let ( +++ ) w1 w2 ~ts ~ns ~lvl msg =
w1 ~ts ~ns ~lvl msg;
w2 ~ts ~ns ~lvl msg
let ( +++ ) w1 w2 ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg =
w1 ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg;
w2 ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg

21
lib/journald.ml
View File

@ -40,13 +40,30 @@ let syslog_priority = function
| WARN -> "4" (* LOG_WARNING *)
| ERROR -> "3" (* LOG_ERR *)
let writer t ~ts ~ns ~lvl msg =
let writer t ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg =
Mutex.lock t.mutex;
let dgram =
Buffer.clear t.buf;
ignore ts;
add_field t.buf "MESSAGE" (Printf.sprintf "%s: %s" ns msg);
let maybe_exn = match exn with
| Some (exn, bt) ->
Printf.sprintf "\nException: %s\n%s" (Printexc.to_string exn)
(Printexc.raw_backtrace_to_string bt)
| None -> ""
in
add_field t.buf "MESSAGE" (Printf.sprintf "%s: %s%s" ns msg maybe_exn);
add_field t.buf "PRIORITY" (syslog_priority lvl);
begin if not (filename = "") then
add_field t.buf "CODE_FILE" filename;
add_field t.buf "CODE_LINE" (Printf.sprintf "%d" lineno)
end;
begin if not (func = "") then
add_field t.buf "CODE_FUNC" func
end;
let errno = Util.get_errno errno exn in
begin if errno != 0 then
add_field t.buf "ERRNO" (Printf.sprintf "%d" errno)
end;
Buffer.to_bytes t.buf
in
Mutex.unlock t.mutex;

54
lib/pretty.ml
View File

@ -13,12 +13,16 @@ type config = {
timestamp : bool;
namespace : bool;
level : bool;
source_loc : bool;
backtrace : bool;
}
let _fl_c = 1 (* color *)
let _fl_t = 2 (* timestamp *)
let _fl_n = 4 (* namespace *)
let _fl_l = 8 (* level *)
let _fl_c = 1 (* color *)
let _fl_t = 2 (* timestamp *)
let _fl_n = 4 (* namespace *)
let _fl_l = 8 (* level *)
let _fl_s = 16 (* source_loc *)
let _fl_b = 32 (* backtrace *)
let _fl_ct = _fl_c + _fl_t
let _fl_cl = _fl_c + _fl_l
@ -40,6 +44,10 @@ let ansi_dim = "\x1b[2m"
let ansi_bold = "\x1b[1m"
let ansi_off = "\x1b[0m"
let box_at = "└─ "
let box_exn = "├─ "
let box_bt = "├─── "
let pr_timestamp bp ts =
Buffer.add_string bp (Time.to_string ts)
@ -65,10 +73,12 @@ let make (out : out_channel) (cfg : config) = {
bp = Buffer.create 512;
align_to = 0;
out;
flags = (if cfg.color then _fl_c else 0) +
(if cfg.timestamp then _fl_t else 0) +
(if cfg.namespace then _fl_n else 0) +
(if cfg.level then _fl_l else 0)
flags = (if cfg.color then _fl_c else 0) +
(if cfg.timestamp then _fl_t else 0) +
(if cfg.namespace then _fl_n else 0) +
(if cfg.level then _fl_l else 0) +
(if cfg.source_loc then _fl_s else 0) +
(if cfg.backtrace then _fl_b else 0)
}
let pr_msg bp msg ts ns lvl ~align ~indent ~f =
@ -91,7 +101,8 @@ let pr_msg bp msg ts ns lvl ~align ~indent ~f =
Buffer.add_string bp "\n";
end
let writer t ~ts ~ns ~lvl msg =
let writer t ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg =
ignore errno;
let f mask = t.flags land mask = mask in
let align bp =
let n = t.align_to - Buffer.length bp in
@ -107,6 +118,31 @@ let writer t ~ts ~ns ~lvl msg =
begin
Mutex.lock t.mutex;
pr_msg t.bp msg ts ns lvl ~align ~indent ~f;
begin match exn with
| Some (exn, bt) ->
Buffer.add_string t.bp box_exn;
Printf.bprintf t.bp "Exception: %s\n" (Printexc.to_string exn);
(* if not called within an exception handler, or backtraces are disabled, we don't get a
backtrace and thus empty string will get added *)
if f _fl_b then begin
let bt_parts = String.split_on_char '\n' (Printexc.raw_backtrace_to_string bt) in
List.iter (fun line ->
if not (String.trim line = "") then begin
Buffer.add_string t.bp box_bt;
Buffer.add_string t.bp line;
Buffer.add_string t.bp "\n" end) bt_parts
end
| None -> ()
end;
if f _fl_s && (not (filename = "") || not (func = "")) then begin
Buffer.add_string t.bp box_at;
begin match (filename, func) with
| ("", _) -> Printf.bprintf t.bp "%s" func
| (_, "") -> Printf.bprintf t.bp "%s:%d" filename lineno
| _ -> Printf.bprintf t.bp "%s @ %s:%d" func filename lineno
end;
Buffer.add_string t.bp "\n"
end;
Buffer.output_buffer t.out t.bp;
flush t.out;
Buffer.clear t.bp;

10
lib/util.ml
View File

@ -7,3 +7,13 @@ let parse_module_name (name : string) : string list =
| fst::rst ->
let fst = Str.global_replace dune_exe_rx "[EXE]" fst in
(Str.split dune_underscore_rx fst) @ rst
external unix_code_of_unix_error : Unix.error -> int = "caml_unix_code_of_unix_error"
let get_errno errno exn =
if errno != 0 then
errno
else
match exn with
| Some ((Unix.Unix_error (err, _, _)), _) -> unix_code_of_unix_error err
| _ -> 0

60
lib/xlog.ml
View File

@ -52,37 +52,61 @@ let rec find_or_make_logger parent_logger ns =
type 'a log_function =
((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
let write logger lvl msg =
type 'a log_module_function =
?__POS__:(string * int * int * int)
-> ?__FUNCTION__:string
-> ?errno:int
-> ('a log_function)
let write logger filename lineno func errno exn lvl msg =
let ts = Time.stamp () in
let ns = logger.namespace in
Option.iter (fun w -> w ~ts ~ns ~lvl msg) logger.writers
Option.iter (fun w -> w ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg) logger.writers
let[@inline] logf logger lvl : _ log_function = fun logk ->
let[@inline] logf logger lvl ~__POS__ ~__FUNCTION__ ~errno ~exn : _ log_function = fun logk ->
if int_of_level lvl >= logger.min_level then
logk (fun fmt ->
Format.kasprintf (write logger lvl)
let (filename, lineno, _, _) = __POS__ in
let func = Util.parse_module_name __FUNCTION__ |> String.concat "." in
Format.kasprintf (write logger filename lineno func errno exn 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
val trace : _ log_module_function
val debug : _ log_module_function
val info : _ log_module_function
val warn : _ log_module_function
val error : _ log_module_function
val exn : exn -> Printexc.raw_backtrace -> _ log_module_function
val log : level -> ?exn:((exn * Printexc.raw_backtrace) option) -> _ log_module_function
end
let make_logs parent_logger ns =
(module struct
let logger = find_or_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
let[@inline] trace
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger TRACE ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] debug
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger DEBUG ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] info
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger INFO ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] warn
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger WARN ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] error
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger ERROR ~__POS__ ~__FUNCTION__ ~errno ~exn:None k
let[@inline] exn exn bt
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger ERROR ~__POS__ ~__FUNCTION__ ~errno ~exn:(Some (exn, bt)) k
let[@inline] log level ?(exn=None)
?(__POS__=("",0,0,0)) ?(__FUNCTION__="") ?(errno=0)
k = logf logger level ~__POS__ ~__FUNCTION__ ~errno ~exn k
end : Logs)
let logs ns = make_logs root_logger (Util.parse_module_name ns)
@ -111,9 +135,11 @@ let init_pretty_writer
?(timestamp = true)
?(namespace = true)
?(level = true)
?(source_loc = true)
?(backtrace = true)
out
=
Pretty.make out { color; timestamp; namespace; level } |>
Pretty.make out { color; timestamp; namespace; level; source_loc; backtrace } |>
Pretty.writer |>
add_writer ?min_level

21
lib/xlog.mli
View File

@ -11,14 +11,21 @@ type level =
type 'a log_function =
((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit
type 'a log_module_function =
?__POS__:(string * int * int * int)
-> ?__FUNCTION__:string
-> ?errno:int
-> ('a log_function)
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
val trace : _ log_module_function
val debug : _ log_module_function
val info : _ log_module_function
val warn : _ log_module_function
val error : _ log_module_function
val exn : exn -> Printexc.raw_backtrace -> _ log_module_function
val log : level -> ?exn:((exn * Printexc.raw_backtrace) option) -> _ log_module_function
end
val logs : string -> (module Logs)
@ -30,6 +37,8 @@ val init_pretty_writer :
?timestamp:bool ->
?namespace:bool ->
?level:bool ->
?source_loc:bool ->
?backtrace:bool ->
out_channel -> unit
val init_journald_writer :