Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

change log file handling #476

Merged
merged 2 commits into from
Dec 20, 2024
Merged

change log file handling #476

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
9414ddc
change log file handling
mabiede Dec 19, 2024
6e26954
Merge branch 'main' into feature/change-log-file-handling
timohuber Dec 20, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions pool/app/logger/dune
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,4 +7,5 @@
ppx_deriving.eq
ppx_deriving.show
ppx_sexp_conv
ppx_string
ppx_variants_conv)))
235 changes: 89 additions & 146 deletions pool/app/logger/logger.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,190 +1,133 @@
let tag_req : string Logs.Tag.def =
Logs.Tag.def "request_id" ~doc:"Rock.Request/Response id" CCString.pp
;;
open Format
open Logs

let tag_ip : string Logs.Tag.def = Logs.Tag.def "request_ip" ~doc:"X-Real-IP" CCString.pp
let tag_req = Tag.def "request_id" ~doc:"Rock.Request/Response id" CCString.pp
let tag_ip = Tag.def "request_ip" ~doc:"X-Real-IP" CCString.pp
let tag_database = Database.Logger.Tags.add_label
let tag_user = Tag.def "user" ~doc:"User / Administrator email" CCString.pp
let app_channel = ref None
let error_channel = ref None

let get_log_level () =
let default = Info in
Sihl.Configuration.read_string "LOG_LEVEL"
|> CCOption.map_or ~default (function
| "debug" -> Debug
| "error" -> Error
| "warning" -> Warning
| _ -> default)
|> CCOption.return
;;

let logs_dir () =
match Sihl.Configuration.root_path (), Sihl.Configuration.read_string "LOGS_DIR" with
| _, Some logs_dir -> logs_dir
| Some root, None -> root ^ "/logs"
| None, None -> "logs"
;;

let tag_user : string Logs.Tag.def =
Logs.Tag.def "user" ~doc:"User / Administrator email" CCString.pp
let init_log_file channel log_file =
match !channel with
| Some _ -> ()
| None ->
let out = open_out_gen [ Open_creat; Open_append; Open_text ] 0o666 log_file in
channel := Some (out, formatter_of_out_channel out)
;;

let empty : Logs.Tag.set = Logs.Tag.empty
let app_style = `Cyan
let err_style = `Red
let warn_style = `Yellow
let info_style = `Blue
let debug_style = `Green
let source_style = `Magenta
let init_out_channels () =
let logs_dir = logs_dir () in
init_log_file app_channel (logs_dir ^ "/app.log");
init_log_file error_channel (logs_dir ^ "/error.log")
;;

(* Adapted from Logs_fmt.pp_header *)
let pp_header ~pp_h ppf (l, h) =
let open Logs_fmt in
match l with
| Logs.App ->
(match h with
| None -> ()
| Some h -> Fmt.pf ppf "[%a] " Fmt.(styled app_style string) h)
| Logs.Error ->
pp_h
ppf
err_style
(match h with
| None -> "ERROR"
| Some h -> h)
| Logs.Warning ->
pp_h
ppf
warn_style
(match h with
| None -> "WARNING"
| Some h -> h)
| Logs.Info ->
pp_h
ppf
info_style
(match h with
| None -> "INFO"
| Some h -> h)
| Logs.Debug ->
pp_h
ppf
debug_style
(match h with
| None -> "DEBUG"
| Some h -> h)
| App -> CCOption.get_or ~default:"APP" h |> pp_h ppf app_style
| Error -> CCOption.get_or ~default:"ERROR" h |> pp_h ppf err_style
| Warning -> CCOption.get_or ~default:"WARNING" h |> pp_h ppf warn_style
| Info -> CCOption.get_or ~default:"INFO" h |> pp_h ppf info_style
| Debug -> CCOption.get_or ~default:"DEBUG" h |> pp_h ppf debug_style
;;

let pp_source = Fmt.(styled source_style string)
let pp_database = Fmt.(styled `Green string)
let pp_user = Fmt.(styled `Cyan string)
let pp_req = Fmt.(styled `Red string)

let pp_exec_header tags src =
let open CCOption.Infix in
let pp_exec_header ?(tags = Tag.empty) src =
let find tag = Tag.find tag tags |> CCOption.get_or ~default:"-" in
let pp_h ppf style level =
let value = CCOption.value ~default:"-" in
let id = tags >>= Logs.Tag.find tag_req |> value in
let ip = tags >>= Logs.Tag.find tag_ip |> value in
let user = tags >>= Logs.Tag.find tag_user |> value in
let database_label = tags >>= Logs.Tag.find tag_database |> value in
let src = Logs.Src.name src in
let now =
let now = Ptime_clock.now () in
Ptime.to_rfc3339 ~tz_offset_s:(Utils.Ptime.to_zurich_tz_offset_s now) now
in
Fmt.pf
ppf
"%s [%a][%a][%a][%a][%a][%a]: "
now
Fmt.(styled style string)
level
pp_source
src
pp_database
database_label
pp_req
ip
pp_req
id
pp_user
user
let pp_styled_values ppf values =
CCList.iter
(fun (color, value) -> fprintf ppf "[%a]" Fmt.(styled color string) value)
values
in
let styles =
[ style, level
; `Magenta, Src.name src
; `Green, find tag_database
; `Red, find tag_ip
; `Red, find tag_req
; `Cyan, find tag_user
]
in
fprintf ppf "%s %a: " now pp_styled_values styles
in
pp_header ~pp_h
;;

let format_reporter
?(pp_header = pp_exec_header)
?(app = Format.std_formatter)
?(dst = Format.err_formatter)
?(app = std_formatter)
?(dst = err_formatter)
()
=
let report src level ~over k msgf =
let k _ =
let k' _ =
over ();
k ()
in
msgf
@@ fun ?header ?tags fmt ->
let ppf = if level = Logs.App then app else dst in
Format.kfprintf k ppf ("%a" ^^ fmt ^^ "@.") (pp_header tags src) (level, header)
let ppf =
match level with
| Logs.Error -> dst
| App | Debug | Info | Warning -> app
in
kfprintf k' ppf ("%a" ^^ fmt ^^ "@.") (pp_header ?tags src) (level, header)
in
{ Logs.report }
;;

let get_log_level () =
match Sihl.Configuration.read_string "LOG_LEVEL" with
| Some "debug" -> Some Logs.Debug
| Some "error" -> Some Logs.Error
| Some "warning" -> Some Logs.Warning
| _ -> Some Logs.Info
;;

let logs_dir () =
match Sihl.Configuration.root_path (), Sihl.Configuration.read_string "LOGS_DIR" with
| _, Some logs_dir -> logs_dir
| Some root, None -> root ^ "/logs"
| None, None -> "logs"
{ report }
;;

let lwt_file_reporter ?(pp_header = pp_exec_header) () =
let logs_dir = logs_dir () in
let buf () =
let b = Buffer.create 512 in
( b
, fun () ->
let m = Buffer.contents b in
Buffer.reset b;
m )
in
let report src level ~over k msgf =
let buf, buf_flush = buf () in
let k _ = k () in
let write () =
let name =
match level with
| Logs.Error -> logs_dir ^ "/error.log"
| Logs.App | Logs.Debug | Logs.Info | Logs.Warning -> logs_dir ^ "/app.log"
in
let%lwt log =
Lwt_io.open_file
~flags:[ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND ]
~perm:0o777
~mode:Lwt_io.Output
name
in
let%lwt () = Lwt_io.write log (buf_flush ()) in
Lwt_io.close log
in
let unblock () =
over ();
Lwt.return_unit
in
(write ()) [%lwt.finally unblock ()] |> Lwt.ignore_result;
msgf
@@ fun ?header ?tags fmt ->
let ppf = Format.formatter_of_buffer buf in
Format.kfprintf k ppf ("%a" ^^ fmt ^^ "@.") (pp_header tags src) (level, header)
in
{ Logs.report }
let rec lwt_file_reporter ?pp_header () =
let () = init_out_channels () in
match !app_channel, !error_channel with
| Some (_, app_fmt), Some (_, error_fmt) ->
format_reporter ?pp_header ~app:app_fmt ~dst:error_fmt ()
| (None | Some _), (None | Some _) ->
init_out_channels ();
lwt_file_reporter ?pp_header ()
;;

let cli_reporter ?(pp_header = pp_exec_header) ?app ?dst () =
let cli_reporter ?pp_header ?app ?dst () =
Fmt_tty.setup_std_outputs ();
format_reporter ~pp_header ?app ?dst ()
format_reporter ?pp_header ?app ?dst ()
;;

let combine r1 r2 =
let report src level ~over k msgf =
let v = r1.Logs.report src level ~over:(fun () -> ()) k msgf in
r2.Logs.report src level ~over (fun () -> v) msgf
let v = r1.report src level ~over:(fun () -> ()) k msgf in
r2.report src level ~over (fun () -> v) msgf
in
{ Logs.report }
{ report }
;;

let reporter =
Logs.set_level (get_log_level ());
let r1 = lwt_file_reporter () in
let r2 = cli_reporter () in
combine r1 r2
set_level (get_log_level ());
if Sihl.Configuration.is_production ()
then lwt_file_reporter ()
else combine (cli_reporter ()) (lwt_file_reporter ())
;;

let create_logs_dir () =
Expand All @@ -193,9 +136,9 @@ let create_logs_dir () =

let log_exception ?prefix ~src ~tags =
let backtrace = Printexc.get_backtrace () in
let prefix = CCOption.map_or ~default:"" (Format.asprintf "%s: ") prefix in
let prefix = CCOption.map_or ~default:"" (asprintf "%s: ") prefix in
let print ?(error_type = "Exception") error_name =
Logs.err ~src (fun m ->
err ~src (fun m ->
m ~tags "%s%s caught: %s, Backtrace: %s" prefix error_type error_name backtrace)
in
function
Expand Down
Empty file removed pool/run/log_reporter.ml
View file
Open in desktop
Empty file.
2 changes: 1 addition & 1 deletion pool/test/test_utils.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,7 @@ let check_result ?(msg = "succeeds") =

(* Helper functions *)

let setup_test ?(log_level = Logs.Info) ?(reporter = Logger.lwt_file_reporter ()) () =
let setup_test ?(log_level = Logs.Info) ?(reporter = Logger.reporter) () =
let open Sihl.Configuration in
let () = read_env_file () |> CCOption.value ~default:[] |> store in
let () = Logs.set_level (Some log_level) in
Expand Down
Loading