1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
type level = Debug | Info | Warn | Error
type value =
| String of string
| Int of int
| Int64 of int64
| Float of float
| Bool of bool
| Redacted
type field = string * value
type event = {
timestamp : Ptime.t;
level : level;
message : string;
fields : field list;
}
type sink = event -> unit
type core = {
sink : sink option;
now : unit -> Ptime.t;
min_level : int Atomic.t;
dropped : int Atomic.t;
lock : Mutex.t;
}
type t = { core : core; fields : field list }
let level_rank = function
| Debug -> 0
| Info -> 1
| Warn -> 2
| Error -> 3
let level_of_rank = function
| value when value <= 0 -> Debug
| 1 -> Info
| 2 -> Warn
| _ -> Error
let level_to_string = function
| Debug -> "debug"
| Info -> "info"
| Warn -> "warn"
| Error -> "error"
let reserved = [ "timestamp"; "level"; "message" ]
let valid_field_char = function
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '.' | '-' | '/' -> true
| _ -> false
let validate_value name = function
| Float value when not (Float.is_finite value) ->
invalid_arg ("Log: non-finite field " ^ name)
| String _ | Int _ | Int64 _ | Float _ | Bool _ | Redacted -> ()
let normalize_fields fields =
let fields = List.sort (fun (a, _) (b, _) -> String.compare a b) fields in
let rec validate previous = function
| [] -> ()
| (name, value) :: rest ->
if name = "" || not (String.for_all valid_field_char name) then
invalid_arg ("Log: invalid field name " ^ name);
if List.mem name reserved then
invalid_arg ("Log: reserved field name " ^ name);
if previous = Some name then invalid_arg ("Log: duplicate field " ^ name);
validate_value name value;
validate (Some name) rest
in
validate None fields;
fields
let merge_fields inherited local =
let local = normalize_fields local in
let local_names = List.map fst local in
List.filter (fun (name, _) -> not (List.mem name local_names)) inherited
@ local
|> List.sort (fun (a, _) (b, _) -> String.compare a b)
let create ?(min_level = Info) ?(now = Ptime_clock.now) ~sink () =
{
core =
{
sink = Some sink;
now;
min_level = Atomic.make (level_rank min_level);
dropped = Atomic.make 0;
lock = Mutex.create ();
};
fields = [];
}
let null =
{
core =
{
sink = None;
now = Ptime_clock.now;
min_level = Atomic.make (level_rank Error);
dropped = Atomic.make 0;
lock = Mutex.create ();
};
fields = [];
}
let value_to_yojson = function
| String value -> `String value
| Int value -> `Int value
| Int64 value -> `Intlit (Int64.to_string value)
| Float value -> `Float value
| Bool value -> `Bool value
| Redacted -> `String "[REDACTED]"
let event_to_yojson event =
`Assoc
([
( "timestamp",
`String (Ptime.to_rfc3339 ~frac_s:6 ~tz_offset_s:0 event.timestamp) );
("level", `String (level_to_string event.level));
("message", `String event.message);
]
@ List.map (fun (name, value) -> (name, value_to_yojson value)) event.fields
)
let stderr ?min_level () =
create ?min_level
~sink:(fun event ->
Yojson.Safe.to_channel Stdlib.stderr (event_to_yojson event);
output_char Stdlib.stderr '\n';
flush Stdlib.stderr)
()
let with_fields logger fields =
{ logger with fields = merge_fields logger.fields fields }
let with_name logger name =
if String.trim name = "" then invalid_arg "Log.with_name: empty name";
with_fields logger [ ("logger", String name) ]
let min_level logger = level_of_rank (Atomic.get logger.core.min_level)
let set_min_level logger level =
Atomic.set logger.core.min_level (level_rank level)
let enabled logger level =
logger.core.sink <> None
&& level_rank level >= Atomic.get logger.core.min_level
let dropped_events logger = Atomic.get logger.core.dropped
let log logger level ?(fields = []) message =
if enabled logger level then (
let event =
{
timestamp = logger.core.now ();
level;
message;
fields = merge_fields logger.fields fields;
}
in
Mutex.lock logger.core.lock;
Fun.protect
~finally:(fun () -> Mutex.unlock logger.core.lock)
(fun () ->
match logger.core.sink with
| None -> ()
| Some sink -> (
try sink event with _ -> Atomic.incr logger.core.dropped)))
let debug logger ?fields message = log logger Debug ?fields message
let info logger ?fields message = log logger Info ?fields message
let warn logger ?fields message = log logger Warn ?fields message
let error logger ?fields message = log logger Error ?fields message