Skip to content

Commit 4efc8ba

Browse files
c-cubec-cube
authored
structured logging (#59)
1 parent f1b26ec commit 4efc8ba

9 files changed

Lines changed: 280 additions & 92 deletions

File tree

‎daemon.ml‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -62,6 +62,12 @@ let unless_exit x = Lwt.pick [wait_exit (); x]
6262
let get_args () =
6363
[
6464
("-loglevel", Arg.String Log.set_loglevels, " ([<facil|prefix*>=]debug|info|warn|error[,])+");
65+
("-logformat",
66+
Arg.Symbol (["plain"; "default"; "logfmt"], (function
67+
| "plain" | "default" -> Log.State.set_plaintext ()
68+
| "logfmt" -> Log.State.set_logfmt ()
69+
| s -> failwith (Printf.sprintf "unknown log format %S" s))),
70+
" Log output format (default: plain)");
6571
ExtArg.may_str "logfile" logfile "<file> Log file";
6672
ExtArg.may_str "pidfile" pidfile "<file> PID file";
6773
"-runas",

‎httpev.ml‎

Lines changed: 12 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -284,7 +284,7 @@ let finish ?(shutdown=true) c =
284284
| Ready req ->
285285
Hashtbl.remove c.server.reqs req.id;
286286
if c.server.config.debug then
287-
log #info "finished %s" (show_request req)
287+
log #info "finished %s" (show_request req) ~structured_pairs:(pairs_of_request req)
288288

289289
let write_f c (data,ack) ev fd _flags =
290290
let finish () = finish c; Ev.del ev in
@@ -324,7 +324,7 @@ let log_access_apache ch code size ?(background=false) req =
324324
(header_safe req "x-request-id")
325325
(if background then " (BG)" else "")
326326
with exn ->
327-
log #warn ~exn "access log : %s" @@ show_request req
327+
log #warn ~exn "access log : %s" (show_request req) ~structured_pairs:(pairs_of_request req)
328328

329329
let log_status_apache ch status size req =
330330
match status with
@@ -498,10 +498,10 @@ let handle_request c body answer =
498498
| `Ok -> answer c.server req k
499499
end
500500
| _ ->
501-
log #info "version %u.%u not supported from %s" (fst req.version) (snd req.version) (show_request req);
501+
log #info "version %u.%u not supported from %s" (fst req.version) (snd req.version) (show_request req) ~structured_pairs:(pairs_of_request req);
502502
send_reply_async c Identity (`Version_not_supported,[],"HTTP/1.0 is supported")
503503
with exn ->
504-
log #error ~exn "answer %s" @@ show_request req;
504+
log #error ~exn "answer %s" (show_request req) ~structured_pairs:(pairs_of_request req);
505505
match req.blocking with
506506
| None -> send_reply_async c Identity (`Not_found,[],"Not found")
507507
| Some _ -> Exn.suppress teardown c.fd
@@ -639,7 +639,7 @@ let check_hung_requests server =
639639
let now = Time.now () in
640640
server.reqs |> Hashtbl.iter begin fun _ req ->
641641
if req.recv -. now > Time.minutes 30 then
642-
log #warn "request takes too much time to process : %s" (show_request req)
642+
log #warn "request takes too much time to process : %s" (show_request req) ~structured_pairs:(pairs_of_request req)
643643
end
644644

645645
let check_waiting_requests srv =
@@ -845,7 +845,7 @@ let answer_blocking ?(debug=false) srv req answer k =
845845
| Continue continue -> 200, Some continue
846846
| exn ->
847847
let saved_backtrace = Exn.get_backtrace () in
848-
log #warn ~exn ~backtrace:debug ~saved_backtrace "answer forked %s" (show_request req);
848+
log #warn ~exn ~backtrace:debug ~saved_backtrace "answer forked %s" (show_request req) ~structured_pairs:(pairs_of_request req);
849849
-1, None
850850
in
851851
if srv.config.access_log_enabled then
@@ -873,7 +873,7 @@ let answer_forked ?debug srv req answer k =
873873
end;
874874
U.sys_exit 0
875875
| `Forked pid ->
876-
log #info "forked %d : %s" pid (show_request req);
876+
log #info "forked %d : %s" pid (show_request req) ~structured_pairs:(pairs_of_request req);
877877
k (`No_reply,[],""); (* close socket in parent immediately *)
878878
Hashtbl.add srv.h_childs pid ()
879879
end
@@ -883,7 +883,7 @@ let answer_forked ?debug srv req answer k =
883883
do_fork ()
884884
with
885885
exn ->
886-
log #warn ~exn "answer fork failed %s" (show_request req);
886+
log #warn ~exn "answer fork failed %s" (show_request req) ~structured_pairs:(pairs_of_request req);
887887
k (`Internal_server_error,[],"")
888888
in
889889
if Hashtbl.length srv.h_childs < srv.config.max_data_childs then
@@ -899,7 +899,7 @@ let answer_forked ?debug srv req answer k =
899899
else
900900
begin
901901
incr nr_rejected;
902-
log #info "rejecting, overloaded : %s" (show_request req);
902+
log #info "rejecting, overloaded : %s" (show_request req) ~structured_pairs:(pairs_of_request req);
903903
k (`Service_unavailable, ["Content-Type", "text/plain"], "overloaded")
904904
end
905905

@@ -989,11 +989,11 @@ let handle_request_lwt c req answer =
989989
try%lwt
990990
answer c.server req
991991
with exn ->
992-
log #error ~exn "answer %s" @@ show_request req;
992+
log #error ~exn "answer %s" (show_request req) ~structured_pairs:(pairs_of_request req);
993993
return (`Not_found,[],"Not found")
994994
end
995995
| _ ->
996-
log #info "version %u.%u not supported from %s" (fst req.version) (snd req.version) (show_request req);
996+
log #info "version %u.%u not supported from %s" (fst req.version) (snd req.version) (show_request req) ~structured_pairs:(pairs_of_request req);
997997
return (`Version_not_supported,[],"HTTP/1.0 is supported")
998998

999999
let read_buf ic buf =
@@ -1163,7 +1163,7 @@ let rest ~show_exn req answer =
11631163
| Arg.Bad s -> bad_request @@ sprintf "bad parameter %s in %s" s req.url
11641164
| exn ->
11651165
let ref = random_ref () in
1166-
log#warn ~exn "failed ref:%Ld %s" ref (show_request req);
1166+
log#warn ~exn "failed ref:%Ld %s" ref (show_request req) ~structured_pairs:(pairs_of_request req);
11671167
if show_exn then
11681168
internal_error @@ sprintf "internal error ref:%Ld : %s" ref (match exn with Failure s -> s | _ -> Exn.str exn)
11691169
else

‎httpev_common.ml‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -106,6 +106,17 @@ let show_request req =
106106
(header_safe req "user-agent")
107107
(header_safe req "x-request-id")
108108

109+
let pairs_of_request req : Logger.Pairs.t =
110+
[ "req_id", string_of_int req.id;
111+
"client_addr", show_client_addr req;
112+
"http_duration", sprintf "%.4f" (Time.get () -. req.conn);
113+
"http_recv_duration", sprintf "%.4f" (req.recv -. req.conn);
114+
"http_host", header_safe req "host";
115+
"url", req.url;
116+
"http_user_agent", header_safe req "user-agent";
117+
"http_req_id", header_safe req "x-request-id"
118+
]
119+
109120
let status_code : reply_status -> int = function
110121
| `Ok -> 200
111122
| `Created -> 201

‎log.ml‎

Lines changed: 75 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,6 @@ open Prelude
4040

4141
(** Global logger state *)
4242
module State = struct
43-
4443
let all = Hashtbl.create 10
4544
let default_level = ref (`Info : Logger.level)
4645

@@ -77,30 +76,64 @@ module State = struct
7776
let output_ch ch =
7877
fun str -> try output_string ch str; flush ch with _ -> () (* logging never fails, most probably ENOSPC *)
7978

80-
let format_simple level facil msg =
79+
let format_simple_full level facil ts pairs msg =
8180
let pid = Unix.getpid () in
8281
let tid = U.gettid () in
8382
let pinfo = if pid = tid then sprintf "%5u:" pid else sprintf "%5u:%u" pid tid in
84-
sprintf "[%s] %s [%s:%s] %s\n"
85-
(Time.to_string ~gmt:!utc_timezone ~ms:true (Unix.gettimeofday ()))
83+
let pairs_str = match pairs with [] -> "" | _ -> " " ^ Logfmt.to_string pairs in
84+
sprintf "[%s] %s [%s:%s] %s%s\n"
85+
(Time.to_string ~gmt:!utc_timezone ~ms:true ts)
8686
pinfo
8787
facil.Logger.name
8888
(Logger.string_level level)
8989
msg
90+
pairs_str
91+
92+
let format_logfmt level facil ts pairs msg =
93+
let pairs = ("msg", msg) :: pairs in
94+
let pid = Unix.getpid () in
95+
let tid = U.gettid () in
96+
let pairs =
97+
if pid = tid then ("pid", string_of_int pid) :: pairs
98+
else ("pid", string_of_int pid) :: ("tid", string_of_int tid) :: pairs
99+
in
100+
let pairs =
101+
("time", Time.to_string ~gmt:!utc_timezone ~ms:true ts) ::
102+
("level", Logger.string_level level) ::
103+
("facil", facil.Logger.name) ::
104+
pairs
105+
in
106+
let buf = Buffer.create 32 in
107+
Logfmt.add_to_buffer buf pairs;
108+
Buffer.add_char buf '\n';
109+
Buffer.contents buf
110+
111+
open struct
112+
let cur_format: ([`Plain|`Logfmt]*_) Atomic.t = Atomic.make (`Plain, format_simple_full)
113+
let set_cur_format f = Atomic.set cur_format f
114+
end
115+
let get_cur_format () = Atomic.get cur_format
116+
let is_structured_format () = match get_cur_format () with `Plain, _ -> false | `Logfmt, _ -> true
117+
let set_plaintext () = set_cur_format (`Plain, format_simple_full)
118+
let set_logfmt () = set_cur_format (`Logfmt, format_logfmt)
119+
120+
let format level facil ts pairs msg =
121+
(snd (Atomic.get cur_format)) level facil ts pairs msg
122+
123+
let format_simple level facil msg =
124+
format level facil (Unix.gettimeofday()) [] msg
90125

91126
let log_ch = stderr
92127
let () = assert (Unix.descr_of_out_channel stderr = Unix.stderr)
93128
let base_name = ref ""
94-
95129
let hook = ref (fun _ _ _ -> ())
130+
let output_simple level facil s = !hook level facil s; output_ch log_ch s
96131

97-
module Put = Logger.PutSimple(
98-
struct
99-
let format = format_simple
100-
let output = fun level facil s -> let () = !hook level facil s in output_ch log_ch s
101-
end)
102-
103-
module M = Logger.Make(Put)
132+
(** Main logger *)
133+
let logger = Logger.put_simple {
134+
format;
135+
output = output_simple;
136+
}
104137

105138
let self = "lib"
106139

@@ -117,12 +150,12 @@ module State = struct
117150
(fun () -> Unix.dup2 (Unix.descr_of_out_channel ch) Unix.stderr)
118151
()
119152
with
120-
e -> M.warn (facility self) "reopen_log_ch(%s) failed : %s" file (Printexc.to_string e)
153+
e ->
154+
let now = (Unix.gettimeofday ()) in
155+
logger.put `Warn (facility self) now [] (sprintf "reopen_log_ch(%s) failed : %s" file (Printexc.to_string e))
121156

122157
end
123158

124-
include State.M
125-
126159
let facility = State.facility
127160
let set_filter = State.set_filter
128161
let set_loglevels = State.set_loglevels
@@ -145,47 +178,52 @@ let read_env_config = State.read_env_config
145178
param [backtrace]: whether to show backtrace if [exn] is given (default is [false])
146179
147180
param [saved_backtrace]: supply backtrace to show instead of using [Printexc.get_backtrace]
181+
182+
param [pairs] key/value pairs to add to the line, unconditionally
183+
184+
param [structured_pairs] key/value pairs to use for structured log formats only. Plain logging will discard.
148185
*)
149-
type 'a pr = ?exn:exn -> ?lines:bool -> ?backtrace:bool -> ?saved_backtrace:string list -> ('a, unit, string, unit) format4 -> 'a
186+
type 'a pr = ?exn:exn -> ?lines:bool -> ?backtrace:bool -> ?saved_backtrace:string list -> ?ts:Time.t -> ?structured_pairs:Logger.Pairs.t -> ?pairs:Logger.Pairs.t -> ('a, unit, string, unit) format4 -> 'a
150187

151188
class logger facil =
152-
let make_s output_line =
189+
let make_s (output_line:Logger.facil -> Time.t -> Logger.Pairs.t -> string -> unit) =
153190
let output = function
154191
| true ->
155-
fun facil s ->
192+
fun facil ts pairs s ->
156193
if String.contains s '\n' then
157-
List.iter (output_line facil) @@ String.nsplit s "\n"
194+
List.iter (output_line facil ts pairs) @@ String.nsplit s "\n"
158195
else
159-
output_line facil s
196+
output_line facil ts pairs s
160197
| false -> output_line
161198
in
162-
let print_bt lines exn bt s =
163-
output lines facil (s ^ " : exn " ^ Exn.str exn ^ (if bt = [] then " (no backtrace)" else ""));
164-
List.iter (fun line -> output_line facil (" " ^ line)) bt
199+
let print_bt lines exn bt ts pairs s =
200+
output lines facil ts pairs (s ^ " : exn " ^ Exn.str exn ^ (if bt = [] then " (no backtrace)" else ""));
201+
List.iter (fun line -> output_line facil ts pairs (" " ^ line)) bt
165202
in
166-
fun ?exn ?(lines=true) ?(backtrace=false) ?saved_backtrace s ->
203+
fun ?exn ?(lines=true) ?(backtrace=false) ?saved_backtrace ?(ts=Unix.gettimeofday()) ?(structured_pairs=[]) ?(pairs=[]) s ->
204+
let pairs = if State.is_structured_format () then List.rev_append structured_pairs pairs else pairs in
167205
try
168206
match exn with
169-
| None -> output lines facil s
207+
| None -> output lines facil ts pairs s
170208
| Some exn ->
171209
match saved_backtrace with
172-
| Some bt -> print_bt lines exn bt s
210+
| Some bt -> print_bt lines exn bt ts pairs s
173211
| None ->
174212
match backtrace with
175-
| true -> print_bt lines exn (Exn.get_backtrace ()) s
176-
| false -> output lines facil (s ^ " : exn " ^ Exn.str exn)
213+
| true -> print_bt lines exn (Exn.get_backtrace ()) ts pairs s
214+
| false -> output lines facil ts pairs (s ^ " : exn " ^ Exn.str exn)
177215
with exn ->
178-
output_line facil (sprintf "LOG FAILED : %S with message %S" (Exn.str exn) s)
216+
output_line facil ts pairs (sprintf "LOG FAILED : %S with message %S" (Exn.str exn) s)
179217
in
180-
let make output ?exn ?lines ?backtrace ?saved_backtrace fmt =
181-
ksprintf (fun s -> output ?exn ?lines ?backtrace ?saved_backtrace s) fmt
218+
let make : _ -> _ pr = fun output ?exn ?lines ?backtrace ?saved_backtrace ?ts ?structured_pairs ?pairs fmt ->
219+
ksprintf (fun s -> output ?exn ?lines ?backtrace ?saved_backtrace ?ts ?structured_pairs ?pairs s) fmt
182220
in
183-
let debug_s = make_s debug_s in
184-
let warn_s = make_s warn_s in
185-
let info_s = make_s info_s in
186-
let error_s = make_s error_s in
187-
let critical_s = make_s critical_s in
188-
let put_s level = make_s (put_s level) in
221+
let debug_s = make_s (State.logger.put `Debug) in
222+
let warn_s = make_s (State.logger.put `Warn) in
223+
let info_s = make_s (State.logger.put `Info) in
224+
let error_s = make_s (State.logger.put `Error) in
225+
let critical_s = make_s (State.logger.put `Critical) in
226+
let put_s level = make_s (State.logger.put level) in
189227
object
190228
method debug_s = debug_s
191229
method warn_s = warn_s

‎logfmt.ml‎

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
2+
let[@inline] needs_escape c =
3+
Char.code c < 0x20 || c = '"' || c = '\\'
4+
5+
let[@inline] needs_quotes c =
6+
c = ' ' || Char.code c >= 0x80
7+
8+
type cat = Safe | Has_space | Needs_escape
9+
10+
let categorize s : cat =
11+
let quote = ref false in
12+
13+
try
14+
for i=0 to String.length s-1 do
15+
let c = String.unsafe_get s i in
16+
if needs_escape c then raise_notrace Exit;
17+
if needs_quotes c then quote := true
18+
done;
19+
if !quote then Has_space else Safe
20+
with Exit -> Needs_escape
21+
22+
let add_pair buf k v =
23+
Buffer.add_string buf k;
24+
Buffer.add_char buf '=';
25+
match categorize v with
26+
| Safe -> Buffer.add_string buf v
27+
| Has_space -> Printf.bprintf buf {|"%s"|} v
28+
| Needs_escape -> Printf.bprintf buf "%S" v
29+
30+
let rec add_to_buffer buf (pairs:Logger.Pairs.t) : unit =
31+
match pairs with
32+
| [] -> ()
33+
| [k,v] -> add_pair buf k v
34+
| (k,v) :: pairs -> add_pair buf k v; Buffer.add_char buf ' '; add_to_buffer buf pairs
35+
36+
let to_string pairs = match pairs with
37+
| [] -> ""
38+
| _ ->
39+
let buf = Buffer.create 32 in
40+
add_to_buffer buf pairs;
41+
Buffer.contents buf

‎logfmt.mli‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
2+
val add_to_buffer : Buffer.t -> Logger.Pairs.t -> unit
3+
val to_string : Logger.Pairs.t -> string

0 commit comments

Comments
 (0)