Source file netlog.ml
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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
open Printf
type level =
[ `Emerg | `Alert | `Crit | `Err | `Warning | `Notice | `Info | `Debug ]
type logger =
level -> string -> unit
type timespec = float * int
type clock_id
type clock =
ly from Netsys_posix *)
| CLOCK_REALTIME
| CLOCK_MONOTONIC
| CLOCK_ID of clock_id
external clock_gettime : clock -> timespec = "netsys_clock_gettime"
let level_weight =
function
| `Emerg -> 0
| `Alert -> 1
| `Crit -> 2
| `Err -> 3
| `Warning -> 4
| `Notice -> 5
| `Info -> 6
| `Debug -> 7
let level_names =
[| "emerg"; "alert"; "crit"; "err"; "warning"; "notice"; "info"; "debug" |]
let string_of_level lev =
level_names.( level_weight lev )
let level_of_string s =
let s = STRING_LOWERCASE s in
match s with
| "emerg" -> `Emerg
| "alert" -> `Alert
| "crit" -> `Crit
| "err" -> `Err
| "warning" -> `Warning
| "notice" -> `Notice
| "info" -> `Info
| "debug" -> `Debug
| _ -> failwith ("Unknown level: " ^ s)
let weekday =
[| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let month =
[| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
"Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]
type format = [ `Std | `ISO ]
let rec ten_power n =
if n<=0 then 1 else 10 * (ten_power (n-1))
let billion = 1_000_000_000
let format_timestamp (fmt:format) digits (s,ns) =
let s0 = floor s in
let ns0 = truncate ( (s -. s0) *. 1E9 ) in
let ns1 = if ns0 >= billion - ns then (ns-billion)+ns0 else ns+ns0 in
let s1 = if ns0 >= billion - ns then s0 +. 1.0 else s0 in
let ns_string =
if digits > 0 then
sprintf ".%0*d" digits (ns1 / ten_power(9-digits))
else
"" in
let t = Unix.localtime s1 in
match fmt with
| `Std ->
sprintf
"%s %s %2d %02d:%02d:%02d%s %4d"
weekday.(t.Unix.tm_wday)
month.(t.Unix.tm_mon)
t.Unix.tm_mday
t.Unix.tm_hour
t.Unix.tm_min
t.Unix.tm_sec
ns_string
(1900 + t.Unix.tm_year)
| `ISO ->
sprintf
"%4d-%02d-%02d %02d:%02d:%02d%s"
(1900 + t.Unix.tm_year)
(t.Unix.tm_mon+1)
t.Unix.tm_mday
t.Unix.tm_hour
t.Unix.tm_min
t.Unix.tm_sec
ns_string
let current_formatter =
ref(format_timestamp `Std 0)
let channel_logger ch max_lev lev msg =
if level_weight lev <= level_weight max_lev then (
let (sec,ns) =
try clock_gettime CLOCK_REALTIME
with Invalid_argument _ ->
(Unix.gettimeofday(), 0) in
let s = * Netdate is unavailable here *)
sprintf
"[%s] [%s] %s%s\n"
(!current_formatter (sec,ns))
(string_of_level lev)
( match lev with
| `Debug ->
sprintf "[%d:%d] "
(Unix.getpid())
(!Netsys_oothr.provider # self # id)
| _ -> ""
)
msg in
output_string ch s;
flush ch
)
let current_logger =
ref(channel_logger stderr `Debug)
let log lev msg =
!current_logger lev msg
let logf level fmt =
Printf.ksprintf (log level) fmt
module Debug = struct
type dlogger =
string -> string -> unit
let fwd_dlogger mname msg =
log `Debug (mname ^ ": " ^ msg)
let null_dlogger _ _ = ()
let current_dlogger =
ref fwd_dlogger
let log mname msg =
!current_dlogger mname msg
let logf mname fmt =
Printf.ksprintf (log mname) fmt
let registry = Hashtbl.create 11
let register_module mname evar =
Hashtbl.replace registry mname evar
let set_module mname b =
try
let evar = Hashtbl.find registry mname in
evar := b
with Not_found -> ()
let set_all_modules b =
Hashtbl.iter
(fun _ evar -> evar := b)
registry
let enable_module mname =
set_module mname true
let disable_module mname =
set_module mname false
let enable_all () =
set_all_modules true
let disable_all () =
set_all_modules false
let names() =
List.sort
compare
(Hashtbl.fold (fun name _ acc -> name::acc) registry [])
let mk_dlog mname enable msg =
if !enable then
log mname msg
let mk_dlogr mname enable f =
if !enable then
log mname (f())
external int64_of_file_descr : Unix.file_descr -> int64
= "netsys_int64_of_file_descr"
type serial = < > ;;
let new_serial() = (object end)
let enable_fd_tracking = ref false
let fd_tab = Hashtbl.create 50
let fd_tab_mutex = !Netsys_oothr.provider # create_mutex()
let fd_string_1 ?(owner=false) ?(descr=false) fd =
try
let (owner_s, descr_s, sn_opt, anchor_entry) =
Hashtbl.find fd_tab fd in
sprintf "%Ld(%s%s%s)"
(int64_of_file_descr fd)
(if owner then owner_s else "")
(if owner && descr then " - " else "")
(if descr then descr_s else "")
with
| Not_found ->
sprintf "%Ld(?)" (int64_of_file_descr fd)
let finalise_anchor r _ =
r := true
let tracker =
"Netlog"
let track_fd ?(update=false) ?anchor ?sn ~owner ~descr fd =
let anchor_entry =
match anchor with
| None -> None
| Some x ->
let r = ref false in
Gc.finalise (finalise_anchor r) x;
Some r
in
Netsys_oothr.serialize
fd_tab_mutex
(fun () ->
if update then (
let verbose =
if Hashtbl.mem fd_tab fd then (
let (_, _, old_sn_opt, _) = Hashtbl.find fd_tab fd in
if old_sn_opt <> None && old_sn_opt <> sn then (
logf tracker "WARNING track_fd: descriptor already tracked \
with different sn as %s"
(fd_string_1 ~owner:true ~descr:true fd);
true
)
else !enable_fd_tracking
)
else !enable_fd_tracking in
Hashtbl.replace fd_tab fd (owner, descr, sn, anchor_entry);
if verbose then
logf tracker "track_fd: updating tracked descriptor %s"
(fd_string_1 ~owner:true ~descr:true fd)
)
else (
let verbose =
if Hashtbl.mem fd_tab fd then (
logf tracker "WARNING track_fd: descriptor already tracked as %s"
(fd_string_1 ~owner:true ~descr:true fd);
true
)
else !enable_fd_tracking in
Hashtbl.replace fd_tab fd (owner, descr, sn, anchor_entry);
if verbose then
logf tracker "track_fd: tracking descriptor %s"
(fd_string_1 ~owner:true ~descr:true fd)
)
)
()
let release_fd ?sn ?(force=false) fd =
Netsys_oothr.serialize
fd_tab_mutex
(fun () ->
try
let (_, _, old_sn_opt, _) = Hashtbl.find fd_tab fd in
let verbose =
if old_sn_opt <> None && old_sn_opt <> sn && not force then (
logf tracker "WARNING release_fd: Descriptor is tracked \
with unexpected sn as %s"
(fd_string_1 ~owner:true ~descr:true fd);
true
)
else !enable_fd_tracking in
if verbose then
logf tracker "release_fd: releasing descriptor %s"
(fd_string_1 ~owner:true ~descr:true fd);
Hashtbl.remove fd_tab fd;
with
| Not_found ->
if not force then
logf tracker "WARNING release_fd: no such descriptor %s"
(fd_string_1 fd)
)
()
let fd_string ?owner ?descr fd =
Netsys_oothr.serialize
fd_tab_mutex
(fun () -> fd_string_1 ?owner ?descr fd)
()
let fd_table () =
Netsys_oothr.serialize
fd_tab_mutex
(fun () ->
let tab =
Hashtbl.fold
(fun fd (owner,descr,_,anchor_flag) acc ->
let n = int64_of_file_descr fd in
let line =
sprintf "%4Ld %-15s %-15s %s"
n
owner
descr
(match anchor_flag with
| Some flag -> if !flag then "DEAD" else ""
| _ -> ""
) in
(n,line) :: acc
)
fd_tab
[] in
let tab' =
List.sort (fun (n1,_) (n2,_) -> Int64.compare n1 n2) tab in
List.map snd tab'
)
()
end