]> git.ipfire.org Git - ipfire-3.x.git/blob - xen/patches/53-upstream-23939:51288f69523f-rework.patch
30fcb1c73015bec1265cdd973be6dbd222a9bef2
[ipfire-3.x.git] / xen / patches / 53-upstream-23939:51288f69523f-rework.patch
1 # HG changeset patch
2 # User Jon Ludlam <jonathan.ludlam@eu.citrix.com>
3 # Date 1317300078 -3600
4 # Node ID f628a2174cd0289400e2fe476cc3177fbcba3c8d
5 # Parent 42cdb34ec175602fa2d8f0f65e44c4eb3a086496
6 [OCAML] Remove log library from tools/ocaml/libs
7
8 This patch has the same effect as xen-unstable.hg c/s 23939:51288f69523f
9
10 The only user was oxenstored, which has had the relevant bits
11 merged in.
12
13 Signed-off-by: Zheng Li <zheng.li@eu.citrix.com>
14 Acked-by: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
15
16 --- a/tools/ocaml/libs/Makefile
17 +++ b/tools/ocaml/libs/Makefile
18 @@ -3,7 +3,7 @@
19
20 SUBDIRS= \
21 mmap \
22 - log xc eventchn \
23 + xc eventchn \
24 xb xs xl
25
26 .PHONY: all
27 --- a/tools/ocaml/libs/log/META.in
28 +++ /dev/null
29 @@ -1,5 +0,0 @@
30 -version = "@VERSION@"
31 -description = "Log - logging library"
32 -requires = "unix"
33 -archive(byte) = "log.cma"
34 -archive(native) = "log.cmxa"
35 --- a/tools/ocaml/libs/log/log.ml
36 +++ /dev/null
37 @@ -1,258 +0,0 @@
38 -(*
39 - * Copyright (C) 2006-2007 XenSource Ltd.
40 - * Copyright (C) 2008 Citrix Ltd.
41 - * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
42 - *
43 - * This program is free software; you can redistribute it and/or modify
44 - * it under the terms of the GNU Lesser General Public License as published
45 - * by the Free Software Foundation; version 2.1 only. with the special
46 - * exception on linking described in file LICENSE.
47 - *
48 - * This program is distributed in the hope that it will be useful,
49 - * but WITHOUT ANY WARRANTY; without even the implied warranty of
50 - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
51 - * GNU Lesser General Public License for more details.
52 - *)
53 -
54 -open Printf
55 -
56 -exception Unknown_level of string
57 -
58 -type stream_type = Stderr | Stdout | File of string
59 -
60 -type stream_log = {
61 - ty : stream_type;
62 - channel : out_channel option ref;
63 -}
64 -
65 -type level = Debug | Info | Warn | Error
66 -
67 -type output =
68 - | Stream of stream_log
69 - | String of string list ref
70 - | Syslog of string
71 - | Nil
72 -
73 -let int_of_level l =
74 - match l with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3
75 -
76 -let string_of_level l =
77 - match l with Debug -> "debug" | Info -> "info"
78 - | Warn -> "warn" | Error -> "error"
79 -
80 -let level_of_string s =
81 - match s with
82 - | "debug" -> Debug
83 - | "info" -> Info
84 - | "warn" -> Warn
85 - | "error" -> Error
86 - | _ -> raise (Unknown_level s)
87 -
88 -let mkdir_safe dir perm =
89 - try Unix.mkdir dir perm with _ -> ()
90 -
91 -let mkdir_rec dir perm =
92 - let rec p_mkdir dir =
93 - let p_name = Filename.dirname dir in
94 - if p_name = "/" || p_name = "." then
95 - ()
96 - else (
97 - p_mkdir p_name;
98 - mkdir_safe dir perm
99 - ) in
100 - p_mkdir dir
101 -
102 -type t = { output: output; mutable level: level; }
103 -
104 -let make output level = { output = output; level = level; }
105 -
106 -let make_stream ty channel =
107 - Stream {ty=ty; channel=ref channel; }
108 -
109 -(** open a syslog logger *)
110 -let opensyslog k level =
111 - make (Syslog k) level
112 -
113 -(** open a stderr logger *)
114 -let openerr level =
115 - if (Unix.stat "/dev/stderr").Unix.st_kind <> Unix.S_CHR then
116 - failwith "/dev/stderr is not a valid character device";
117 - make (make_stream Stderr (Some (open_out "/dev/stderr"))) level
118 -
119 -let openout level =
120 - if (Unix.stat "/dev/stdout").Unix.st_kind <> Unix.S_CHR then
121 - failwith "/dev/stdout is not a valid character device";
122 - make (make_stream Stdout (Some (open_out "/dev/stdout"))) level
123 -
124 -
125 -(** open a stream logger - returning the channel. *)
126 -(* This needs to be separated from 'openfile' so we can reopen later *)
127 -let doopenfile filename =
128 - if Filename.is_relative filename then
129 - None
130 - else (
131 - try
132 - mkdir_rec (Filename.dirname filename) 0o700;
133 - Some (open_out_gen [ Open_append; Open_creat ] 0o600 filename)
134 - with _ -> None
135 - )
136 -
137 -(** open a stream logger - returning the output type *)
138 -let openfile filename level =
139 - make (make_stream (File filename) (doopenfile filename)) level
140 -
141 -(** open a nil logger *)
142 -let opennil () =
143 - make Nil Error
144 -
145 -(** open a string logger *)
146 -let openstring level =
147 - make (String (ref [""])) level
148 -
149 -(** try to reopen a logger *)
150 -let reopen t =
151 - match t.output with
152 - | Nil -> t
153 - | Syslog k -> Syslog.close (); opensyslog k t.level
154 - | Stream s -> (
155 - match (s.ty,!(s.channel)) with
156 - | (File filename, Some c) -> close_out c; s.channel := (try doopenfile filename with _ -> None); t
157 - | _ -> t)
158 - | String _ -> t
159 -
160 -(** close a logger *)
161 -let close t =
162 - match t.output with
163 - | Nil -> ()
164 - | Syslog k -> Syslog.close ();
165 - | Stream s -> (
166 - match !(s.channel) with
167 - | Some c -> close_out c; s.channel := None
168 - | None -> ())
169 - | String _ -> ()
170 -
171 -(** create a string representating the parameters of the logger *)
172 -let string_of_logger t =
173 - match t.output with
174 - | Nil -> "nil"
175 - | Syslog k -> sprintf "syslog:%s" k
176 - | String _ -> "string"
177 - | Stream s ->
178 - begin
179 - match s.ty with
180 - | File f -> sprintf "file:%s" f
181 - | Stderr -> "stderr"
182 - | Stdout -> "stdout"
183 - end
184 -
185 -(** parse a string to a logger *)
186 -let logger_of_string s : t =
187 - match s with
188 - | "nil" -> opennil ()
189 - | "stderr" -> openerr Debug
190 - | "stdout" -> openout Debug
191 - | "string" -> openstring Debug
192 - | _ ->
193 - let split_in_2 s =
194 - try
195 - let i = String.index s ':' in
196 - String.sub s 0 (i),
197 - String.sub s (i + 1) (String.length s - i - 1)
198 - with _ ->
199 - failwith "logger format error: expecting string:string"
200 - in
201 - let k, s = split_in_2 s in
202 - match k with
203 - | "syslog" -> opensyslog s Debug
204 - | "file" -> openfile s Debug
205 - | _ -> failwith "unknown logger type"
206 -
207 -let validate s =
208 - match s with
209 - | "nil" -> ()
210 - | "stderr" -> ()
211 - | "stdout" -> ()
212 - | "string" -> ()
213 - | _ ->
214 - let split_in_2 s =
215 - try
216 - let i = String.index s ':' in
217 - String.sub s 0 (i),
218 - String.sub s (i + 1) (String.length s - i - 1)
219 - with _ ->
220 - failwith "logger format error: expecting string:string"
221 - in
222 - let k, s = split_in_2 s in
223 - match k with
224 - | "syslog" -> ()
225 - | "file" -> (
226 - try
227 - let st = Unix.stat s in
228 - if st.Unix.st_kind <> Unix.S_REG then
229 - failwith "logger file is a directory";
230 - ()
231 - with Unix.Unix_error (Unix.ENOENT, _, _) -> ()
232 - )
233 - | _ -> failwith "unknown logger"
234 -
235 -(** change a logger level to level *)
236 -let set t level = t.level <- level
237 -
238 -let gettimestring () =
239 - let time = Unix.gettimeofday () in
240 - let tm = Unix.localtime time in
241 - let msec = time -. (floor time) in
242 - sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d|" (1900 + tm.Unix.tm_year)
243 - (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
244 - tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
245 - (int_of_float (1000.0 *. msec))
246 -
247 -(*let extra_hook = ref (fun x -> x)*)
248 -
249 -let output t ?(key="") ?(extra="") priority (message: string) =
250 - let construct_string withtime =
251 - (*let key = if key = "" then [] else [ key ] in
252 - let extra = if extra = "" then [] else [ extra ] in
253 - let items =
254 - (if withtime then [ gettimestring () ] else [])
255 - @ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ message ] in
256 -(* let items = !extra_hook items in*)
257 - String.concat " " items*)
258 - Printf.sprintf "[%s%s|%s] %s"
259 - (if withtime then gettimestring () else "") (string_of_level priority) extra message
260 - in
261 - (* Keep track of how much we write out to streams, so that we can *)
262 - (* log-rotate at appropriate times *)
263 - let write_to_stream stream =
264 - let string = (construct_string true) in
265 - try
266 - fprintf stream "%s\n%!" string
267 - with _ -> () (* Trap exception when we fail to write log *)
268 - in
269 -
270 - if String.length message > 0 then
271 - match t.output with
272 - | Syslog k ->
273 - let sys_prio = match priority with
274 - | Debug -> Syslog.Debug
275 - | Info -> Syslog.Info
276 - | Warn -> Syslog.Warning
277 - | Error -> Syslog.Err in
278 - Syslog.log Syslog.Daemon sys_prio ((construct_string false) ^ "\n")
279 - | Stream s -> (
280 - match !(s.channel) with
281 - | Some c -> write_to_stream c
282 - | None -> ())
283 - | Nil -> ()
284 - | String s -> (s := (construct_string true)::!s)
285 -
286 -let log t level (fmt: ('a, unit, string, unit) format4): 'a =
287 - let b = (int_of_level t.level) <= (int_of_level level) in
288 - (* ksprintf is the preferred name for kprintf, but the former
289 - * is not available in OCaml 3.08.3 *)
290 - Printf.kprintf (if b then output t level else (fun _ -> ())) fmt
291 -
292 -let debug t (fmt: ('a , unit, string, unit) format4) = log t Debug fmt
293 -let info t (fmt: ('a , unit, string, unit) format4) = log t Info fmt
294 -let warn t (fmt: ('a , unit, string, unit) format4) = log t Warn fmt
295 -let error t (fmt: ('a , unit, string, unit) format4) = log t Error fmt
296 --- a/tools/ocaml/libs/log/log.mli
297 +++ /dev/null
298 @@ -1,55 +0,0 @@
299 -(*
300 - * Copyright (C) 2006-2007 XenSource Ltd.
301 - * Copyright (C) 2008 Citrix Ltd.
302 - * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
303 - *
304 - * This program is free software; you can redistribute it and/or modify
305 - * it under the terms of the GNU Lesser General Public License as published
306 - * by the Free Software Foundation; version 2.1 only. with the special
307 - * exception on linking described in file LICENSE.
308 - *
309 - * This program is distributed in the hope that it will be useful,
310 - * but WITHOUT ANY WARRANTY; without even the implied warranty of
311 - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
312 - * GNU Lesser General Public License for more details.
313 - *)
314 -
315 -exception Unknown_level of string
316 -type level = Debug | Info | Warn | Error
317 -
318 -type stream_type = Stderr | Stdout | File of string
319 -type stream_log = {
320 - ty : stream_type;
321 - channel : out_channel option ref;
322 -}
323 -type output =
324 - Stream of stream_log
325 - | String of string list ref
326 - | Syslog of string
327 - | Nil
328 -val int_of_level : level -> int
329 -val string_of_level : level -> string
330 -val level_of_string : string -> level
331 -val mkdir_safe : string -> Unix.file_perm -> unit
332 -val mkdir_rec : string -> Unix.file_perm -> unit
333 -type t = { output : output; mutable level : level; }
334 -val make : output -> level -> t
335 -val opensyslog : string -> level -> t
336 -val openerr : level -> t
337 -val openout : level -> t
338 -val openfile : string -> level -> t
339 -val opennil : unit -> t
340 -val openstring : level -> t
341 -val reopen : t -> t
342 -val close : t -> unit
343 -val string_of_logger : t -> string
344 -val logger_of_string : string -> t
345 -val validate : string -> unit
346 -val set : t -> level -> unit
347 -val gettimestring : unit -> string
348 -val output : t -> ?key:string -> ?extra:string -> level -> string -> unit
349 -val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
350 -val debug : t -> ('a, unit, string, unit) format4 -> 'a
351 -val info : t -> ('a, unit, string, unit) format4 -> 'a
352 -val warn : t -> ('a, unit, string, unit) format4 -> 'a
353 -val error : t -> ('a, unit, string, unit) format4 -> 'a
354 --- a/tools/ocaml/libs/log/logs.ml
355 +++ /dev/null
356 @@ -1,197 +0,0 @@
357 -(*
358 - * Copyright (C) 2006-2007 XenSource Ltd.
359 - * Copyright (C) 2008 Citrix Ltd.
360 - * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
361 - *
362 - * This program is free software; you can redistribute it and/or modify
363 - * it under the terms of the GNU Lesser General Public License as published
364 - * by the Free Software Foundation; version 2.1 only. with the special
365 - * exception on linking described in file LICENSE.
366 - *
367 - * This program is distributed in the hope that it will be useful,
368 - * but WITHOUT ANY WARRANTY; without even the implied warranty of
369 - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
370 - * GNU Lesser General Public License for more details.
371 - *)
372 -
373 -type keylogger =
374 -{
375 - mutable debug: string list;
376 - mutable info: string list;
377 - mutable warn: string list;
378 - mutable error: string list;
379 - no_default: bool;
380 -}
381 -
382 -(* map all logger strings into a logger *)
383 -let __all_loggers = Hashtbl.create 10
384 -
385 -(* default logger that everything that doesn't have a key in __lop_mapping get send *)
386 -let __default_logger = { debug = []; info = []; warn = []; error = []; no_default = false }
387 -
388 -(*
389 - * This describe the mapping between a name to a keylogger.
390 - * a keylogger contains a list of logger string per level of debugging.
391 - * Example: "xenops", debug -> [ "stderr"; "/var/log/xensource.log" ]
392 - * "xapi", error -> []
393 - * "xapi", debug -> [ "/var/log/xensource.log" ]
394 - * "xenops", info -> [ "syslog" ]
395 - *)
396 -let __log_mapping = Hashtbl.create 32
397 -
398 -let get_or_open logstring =
399 - if Hashtbl.mem __all_loggers logstring then
400 - Hashtbl.find __all_loggers logstring
401 - else
402 - let t = Log.logger_of_string logstring in
403 - Hashtbl.add __all_loggers logstring t;
404 - t
405 -
406 -(** create a mapping entry for the key "name".
407 - * all log level of key "name" default to "logger" logger.
408 - * a sensible default is put "nil" as a logger and reopen a specific level to
409 - * the logger you want to.
410 - *)
411 -let add key logger =
412 - let kl = {
413 - debug = logger;
414 - info = logger;
415 - warn = logger;
416 - error = logger;
417 - no_default = false;
418 - } in
419 - Hashtbl.add __log_mapping key kl
420 -
421 -let get_by_level keylog level =
422 - match level with
423 - | Log.Debug -> keylog.debug
424 - | Log.Info -> keylog.info
425 - | Log.Warn -> keylog.warn
426 - | Log.Error -> keylog.error
427 -
428 -let set_by_level keylog level logger =
429 - match level with
430 - | Log.Debug -> keylog.debug <- logger
431 - | Log.Info -> keylog.info <- logger
432 - | Log.Warn -> keylog.warn <- logger
433 - | Log.Error -> keylog.error <- logger
434 -
435 -(** set a specific key|level to the logger "logger" *)
436 -let set key level logger =
437 - if not (Hashtbl.mem __log_mapping key) then
438 - add key [];
439 -
440 - let keylog = Hashtbl.find __log_mapping key in
441 - set_by_level keylog level logger
442 -
443 -(** set default logger *)
444 -let set_default level logger =
445 - set_by_level __default_logger level logger
446 -
447 -(** append a logger to the list *)
448 -let append key level logger =
449 - if not (Hashtbl.mem __log_mapping key) then
450 - add key [];
451 - let keylog = Hashtbl.find __log_mapping key in
452 - let loggers = get_by_level keylog level in
453 - set_by_level keylog level (loggers @ [ logger ])
454 -
455 -(** append a logger to the default list *)
456 -let append_default level logger =
457 - let loggers = get_by_level __default_logger level in
458 - set_by_level __default_logger level (loggers @ [ logger ])
459 -
460 -(** reopen all logger open *)
461 -let reopen () =
462 - Hashtbl.iter (fun k v ->
463 - Hashtbl.replace __all_loggers k (Log.reopen v)) __all_loggers
464 -
465 -(** reclaim close all logger open that are not use by any other keys *)
466 -let reclaim () =
467 - let list_sort_uniq l =
468 - let oldprev = ref "" and prev = ref "" in
469 - List.fold_left (fun a k ->
470 - oldprev := !prev;
471 - prev := k;
472 - if k = !oldprev then a else k :: a) []
473 - (List.sort compare l)
474 - in
475 - let flatten_keylogger v =
476 - list_sort_uniq (v.debug @ v.info @ v.warn @ v.error) in
477 - let oldkeys = Hashtbl.fold (fun k v a -> k :: a) __all_loggers [] in
478 - let usedkeys = Hashtbl.fold (fun k v a ->
479 - (flatten_keylogger v) @ a)
480 - __log_mapping (flatten_keylogger __default_logger) in
481 - let usedkeys = list_sort_uniq usedkeys in
482 -
483 - List.iter (fun k ->
484 - if not (List.mem k usedkeys) then (
485 - begin try
486 - Log.close (Hashtbl.find __all_loggers k)
487 - with
488 - Not_found -> ()
489 - end;
490 - Hashtbl.remove __all_loggers k
491 - )) oldkeys
492 -
493 -(** clear a specific key|level *)
494 -let clear key level =
495 - try
496 - let keylog = Hashtbl.find __log_mapping key in
497 - set_by_level keylog level [];
498 - reclaim ()
499 - with Not_found ->
500 - ()
501 -
502 -(** clear a specific default level *)
503 -let clear_default level =
504 - set_default level [];
505 - reclaim ()
506 -
507 -(** reset all the loggers to the specified logger *)
508 -let reset_all logger =
509 - Hashtbl.clear __log_mapping;
510 - set_default Log.Debug logger;
511 - set_default Log.Warn logger;
512 - set_default Log.Error logger;
513 - set_default Log.Info logger;
514 - reclaim ()
515 -
516 -(** log a fmt message to the key|level logger specified in the log mapping.
517 - * if the logger doesn't exist, assume nil logger.
518 - *)
519 -let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a =
520 - let keylog =
521 - if Hashtbl.mem __log_mapping key then
522 - let keylog = Hashtbl.find __log_mapping key in
523 - if keylog.no_default = false &&
524 - get_by_level keylog level = [] then
525 - __default_logger
526 - else
527 - keylog
528 - else
529 - __default_logger in
530 - let loggers = get_by_level keylog level in
531 - match loggers with
532 - | [] -> Printf.kprintf ignore fmt
533 - | _ ->
534 - let l = List.fold_left (fun acc logger ->
535 - try get_or_open logger :: acc
536 - with _ -> acc
537 - ) [] loggers in
538 - let l = List.rev l in
539 -
540 - (* ksprintf is the preferred name for kprintf, but the former
541 - * is not available in OCaml 3.08.3 *)
542 - Printf.kprintf (fun s ->
543 - List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt
544 -
545 -(* define some convenience functions *)
546 -let debug t ?extra (fmt: ('a , unit, string, unit) format4) =
547 - log t Log.Debug ?extra fmt
548 -let info t ?extra (fmt: ('a , unit, string, unit) format4) =
549 - log t Log.Info ?extra fmt
550 -let warn t ?extra (fmt: ('a , unit, string, unit) format4) =
551 - log t Log.Warn ?extra fmt
552 -let error t ?extra (fmt: ('a , unit, string, unit) format4) =
553 - log t Log.Error ?extra fmt
554 --- a/tools/ocaml/libs/log/logs.mli
555 +++ /dev/null
556 @@ -1,46 +0,0 @@
557 -(*
558 - * Copyright (C) 2006-2007 XenSource Ltd.
559 - * Copyright (C) 2008 Citrix Ltd.
560 - * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
561 - *
562 - * This program is free software; you can redistribute it and/or modify
563 - * it under the terms of the GNU Lesser General Public License as published
564 - * by the Free Software Foundation; version 2.1 only. with the special
565 - * exception on linking described in file LICENSE.
566 - *
567 - * This program is distributed in the hope that it will be useful,
568 - * but WITHOUT ANY WARRANTY; without even the implied warranty of
569 - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
570 - * GNU Lesser General Public License for more details.
571 - *)
572 -
573 -type keylogger = {
574 - mutable debug : string list;
575 - mutable info : string list;
576 - mutable warn : string list;
577 - mutable error : string list;
578 - no_default : bool;
579 -}
580 -val __all_loggers : (string, Log.t) Hashtbl.t
581 -val __default_logger : keylogger
582 -val __log_mapping : (string, keylogger) Hashtbl.t
583 -val get_or_open : string -> Log.t
584 -val add : string -> string list -> unit
585 -val get_by_level : keylogger -> Log.level -> string list
586 -val set_by_level : keylogger -> Log.level -> string list -> unit
587 -val set : string -> Log.level -> string list -> unit
588 -val set_default : Log.level -> string list -> unit
589 -val append : string -> Log.level -> string -> unit
590 -val append_default : Log.level -> string -> unit
591 -val reopen : unit -> unit
592 -val reclaim : unit -> unit
593 -val clear : string -> Log.level -> unit
594 -val clear_default : Log.level -> unit
595 -val reset_all : string list -> unit
596 -val log :
597 - string ->
598 - Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
599 -val debug : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
600 -val info : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
601 -val warn : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
602 -val error : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
603 --- a/tools/ocaml/libs/log/syslog.ml
604 +++ /dev/null
605 @@ -1,26 +0,0 @@
606 -(*
607 - * Copyright (C) 2006-2007 XenSource Ltd.
608 - * Copyright (C) 2008 Citrix Ltd.
609 - * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
610 - *
611 - * This program is free software; you can redistribute it and/or modify
612 - * it under the terms of the GNU Lesser General Public License as published
613 - * by the Free Software Foundation; version 2.1 only. with the special
614 - * exception on linking described in file LICENSE.
615 - *
616 - * This program is distributed in the hope that it will be useful,
617 - * but WITHOUT ANY WARRANTY; without even the implied warranty of
618 - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
619 - * GNU Lesser General Public License for more details.
620 - *)
621 -
622 -type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
623 -type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
624 -type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern
625 - | Local0 | Local1 | Local2 | Local3
626 - | Local4 | Local5 | Local6 | Local7
627 - | Lpr | Mail | News | Syslog | User | Uucp
628 -
629 -(* external init : string -> options list -> facility -> unit = "stub_openlog" *)
630 -external log : facility -> level -> string -> unit = "stub_syslog"
631 -external close : unit -> unit = "stub_closelog"
632 --- a/tools/ocaml/libs/log/syslog_stubs.c
633 +++ /dev/null
634 @@ -1,75 +0,0 @@
635 -/*
636 - * Copyright (C) 2006-2007 XenSource Ltd.
637 - * Copyright (C) 2008 Citrix Ltd.
638 - * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
639 - *
640 - * This program is free software; you can redistribute it and/or modify
641 - * it under the terms of the GNU Lesser General Public License as published
642 - * by the Free Software Foundation; version 2.1 only. with the special
643 - * exception on linking described in file LICENSE.
644 - *
645 - * This program is distributed in the hope that it will be useful,
646 - * but WITHOUT ANY WARRANTY; without even the implied warranty of
647 - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
648 - * GNU Lesser General Public License for more details.
649 - */
650 -
651 -#include <syslog.h>
652 -#include <caml/mlvalues.h>
653 -#include <caml/memory.h>
654 -#include <caml/alloc.h>
655 -#include <caml/custom.h>
656 -
657 -static int __syslog_level_table[] = {
658 - LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING,
659 - LOG_NOTICE, LOG_INFO, LOG_DEBUG
660 -};
661 -
662 -/*
663 -static int __syslog_options_table[] = {
664 - LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID
665 -};
666 -*/
667 -
668 -static int __syslog_facility_table[] = {
669 - LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN,
670 - LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3,
671 - LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7,
672 - LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP
673 -};
674 -
675 -/* According to the openlog manpage the 'openlog' call may take a reference
676 - to the 'ident' string and keep it long-term. This means we cannot just pass in
677 - an ocaml string which is under the control of the GC. Since we aren't actually
678 - calling this function we can just comment it out for the time-being. */
679 -/*
680 -value stub_openlog(value ident, value option, value facility)
681 -{
682 - CAMLparam3(ident, option, facility);
683 - int c_option;
684 - int c_facility;
685 -
686 - c_option = caml_convert_flag_list(option, __syslog_options_table);
687 - c_facility = __syslog_facility_table[Int_val(facility)];
688 - openlog(String_val(ident), c_option, c_facility);
689 - CAMLreturn(Val_unit);
690 -}
691 -*/
692 -
693 -value stub_syslog(value facility, value level, value msg)
694 -{
695 - CAMLparam3(facility, level, msg);
696 - int c_facility;
697 -
698 - c_facility = __syslog_facility_table[Int_val(facility)]
699 - | __syslog_level_table[Int_val(level)];
700 - syslog(c_facility, "%s", String_val(msg));
701 - CAMLreturn(Val_unit);
702 -}
703 -
704 -value stub_closelog(value unit)
705 -{
706 - CAMLparam1(unit);
707 - closelog();
708 - CAMLreturn(Val_unit);
709 -}
710 --- a/tools/ocaml/xenstored/Makefile
711 +++ b/tools/ocaml/xenstored/Makefile
712 @@ -3,7 +3,6 @@
713 include $(OCAML_TOPLEVEL)/common.make
714
715 OCAMLINCLUDE += \
716 - -I $(OCAML_TOPLEVEL)/libs/log \
717 -I $(OCAML_TOPLEVEL)/libs/xb \
718 -I $(OCAML_TOPLEVEL)/libs/mmap \
719 -I $(OCAML_TOPLEVEL)/libs/xc \
720 @@ -34,7 +33,6 @@
721 XENSTOREDLIBS = \
722 unix.cmxa \
723 -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \
724 - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/log $(OCAML_TOPLEVEL)/libs/log/log.cmxa \
725 -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \
726 -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \
727 -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xenbus.cmxa \
728 --- a/tools/ocaml/xenstored/connection.ml
729 +++ b/tools/ocaml/xenstored/connection.ml
730 @@ -232,3 +232,8 @@
731 Printf.fprintf chan "watch,%d,%s,%s\n" domid (Utils.hexify path) (Utils.hexify token)
732 ) (list_watches con);
733 | None -> ()
734 +
735 +let debug con =
736 + let domid = get_domstr con in
737 + let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in
738 + String.concat "" watches
739 --- a/tools/ocaml/xenstored/connections.ml
740 +++ b/tools/ocaml/xenstored/connections.ml
741 @@ -15,7 +15,7 @@
742 * GNU Lesser General Public License for more details.
743 *)
744
745 -let debug fmt = Logs.debug "general" fmt
746 +let debug fmt = Logging.debug "connections" fmt
747
748 type t = {
749 mutable anonymous: Connection.t list;
750 @@ -165,3 +165,8 @@
751 );
752 (List.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon,
753 Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom)
754 +
755 +let debug cons =
756 + let anonymous = List.map Connection.debug cons.anonymous in
757 + let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in
758 + String.concat "" (domains @ anonymous)
759 --- a/tools/ocaml/xenstored/disk.ml
760 +++ b/tools/ocaml/xenstored/disk.ml
761 @@ -17,7 +17,7 @@
762 let enable = ref false
763 let xs_daemon_database = "/var/run/xenstored/db"
764
765 -let error = Logs.error "general"
766 +let error fmt = Logging.error "disk" fmt
767
768 (* unescape utils *)
769 exception Bad_escape
770 --- a/tools/ocaml/xenstored/domain.ml
771 +++ b/tools/ocaml/xenstored/domain.ml
772 @@ -16,7 +16,7 @@
773
774 open Printf
775
776 -let debug fmt = Logs.debug "general" fmt
777 +let debug fmt = Logging.debug "domain" fmt
778
779 type t =
780 {
781 --- a/tools/ocaml/xenstored/domains.ml
782 +++ b/tools/ocaml/xenstored/domains.ml
783 @@ -14,6 +14,8 @@
784 * GNU Lesser General Public License for more details.
785 *)
786
787 +let debug fmt = Logging.debug "domains" fmt
788 +
789 type domains = {
790 eventchn: Event.t;
791 table: (Xenctrl.domid, Domain.t) Hashtbl.t;
792 @@ -35,7 +37,7 @@
793 try
794 let info = Xenctrl.domain_getinfo xc id in
795 if info.Xenctrl.shutdown || info.Xenctrl.dying then (
796 - Logs.debug "general" "Domain %u died (dying=%b, shutdown %b -- code %d)"
797 + debug "Domain %u died (dying=%b, shutdown %b -- code %d)"
798 id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code;
799 if info.Xenctrl.dying then
800 dead_dom := id :: !dead_dom
801 @@ -43,7 +45,7 @@
802 notify := true;
803 )
804 with Xenctrl.Error _ ->
805 - Logs.debug "general" "Domain %u died -- no domain info" id;
806 + debug "Domain %u died -- no domain info" id;
807 dead_dom := id :: !dead_dom;
808 ) doms.table;
809 List.iter (fun id ->
810 --- a/tools/ocaml/xenstored/logging.ml
811 +++ b/tools/ocaml/xenstored/logging.ml
812 @@ -17,21 +17,122 @@
813 open Stdext
814 open Printf
815
816 -let error fmt = Logs.error "general" fmt
817 -let info fmt = Logs.info "general" fmt
818 -let debug fmt = Logs.debug "general" fmt
819
820 -let access_log_file = ref "/var/log/xenstored-access.log"
821 -let access_log_nb_files = ref 20
822 -let access_log_nb_lines = ref 13215
823 -let activate_access_log = ref true
824 +(* Logger common *)
825 +
826 +type logger =
827 + { stop: unit -> unit;
828 + restart: unit -> unit;
829 + rotate: unit -> unit;
830 + write: 'a. ('a, unit, string, unit) format4 -> 'a }
831 +
832 +let truncate_line nb_chars line =
833 + if String.length line > nb_chars - 1 then
834 + let len = max (nb_chars - 1) 2 in
835 + let dst_line = String.create len in
836 + String.blit line 0 dst_line 0 (len - 2);
837 + dst_line.[len-2] <- '.';
838 + dst_line.[len-1] <- '.';
839 + dst_line
840 + else line
841 +
842 +let log_rotate ref_ch log_file log_nb_files =
843 + let file n = sprintf "%s.%i" log_file n in
844 + let log_files =
845 + let rec aux accu n =
846 + if n >= log_nb_files then accu
847 + else
848 + if n = 1 && Sys.file_exists log_file
849 + then aux [log_file,1] 2
850 + else
851 + let file = file (n-1) in
852 + if Sys.file_exists file then
853 + aux ((file, n) :: accu) (n+1)
854 + else accu in
855 + aux [] 1 in
856 + List.iter (fun (f, n) -> Unix.rename f (file n)) log_files;
857 + close_out !ref_ch;
858 + ref_ch := open_out log_file
859 +
860 +let make_logger log_file log_nb_files log_nb_lines log_nb_chars post_rotate =
861 + let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in
862 + let counter = ref 0 in
863 + let stop() =
864 + try flush !channel; close_out !channel
865 + with _ -> () in
866 + let restart() =
867 + stop();
868 + channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in
869 + let rotate() =
870 + log_rotate channel log_file log_nb_files;
871 + (post_rotate (): unit);
872 + counter := 0 in
873 + let output s =
874 + let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in
875 + let s = s ^ "\n" in
876 + output_string !channel s;
877 + flush !channel;
878 + incr counter;
879 + if !counter > log_nb_lines then rotate() in
880 + { stop=stop; restart=restart; rotate=rotate; write = fun fmt -> Printf.ksprintf output fmt }
881 +
882 +
883 +(* Xenstored logger *)
884 +
885 +exception Unknown_level of string
886 +
887 +type level = Debug | Info | Warn | Error | Null
888 +
889 +let int_of_level = function
890 + | Debug -> 0 | Info -> 1 | Warn -> 2
891 + | Error -> 3 | Null -> max_int
892 +
893 +let string_of_level = function
894 + | Debug -> "debug" | Info -> "info" | Warn -> "warn"
895 + | Error -> "error" | Null -> "null"
896 +
897 +let level_of_string = function
898 + | "debug" -> Debug | "info" -> Info | "warn" -> Warn
899 + | "error" -> Error | "null" -> Null | s -> raise (Unknown_level s)
900 +
901 +let string_of_date () =
902 + let time = Unix.gettimeofday () in
903 + let tm = Unix.gmtime time in
904 + let msec = time -. (floor time) in
905 + sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ"
906 + (1900 + tm.Unix.tm_year) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
907 + tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
908 + (int_of_float (1000.0 *. msec))
909
910 -(* maximal size of the lines in xenstore-acces.log file *)
911 -let line_size = 180
912 +let xenstored_log_file = ref "/var/log/xenstored.log"
913 +let xenstored_log_level = ref Null
914 +let xenstored_log_nb_files = ref 10
915 +let xenstored_log_nb_lines = ref 13215
916 +let xenstored_log_nb_chars = ref (-1)
917 +let xenstored_logger = ref (None: logger option)
918 +
919 +let init_xenstored_log () =
920 + if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then
921 + let logger =
922 + make_logger
923 + !xenstored_log_file !xenstored_log_nb_files !xenstored_log_nb_lines
924 + !xenstored_log_nb_chars ignore in
925 + xenstored_logger := Some logger
926 +
927 +let xenstored_logging level key (fmt: (_,_,_,_) format4) =
928 + match !xenstored_logger with
929 + | Some logger when int_of_level level >= int_of_level !xenstored_log_level ->
930 + let date = string_of_date() in
931 + let level = string_of_level level in
932 + logger.write ("[%s|%5s|%s] " ^^ fmt) date level key
933 + | _ -> Printf.ksprintf ignore fmt
934 +
935 +let debug key = xenstored_logging Debug key
936 +let info key = xenstored_logging Info key
937 +let warn key = xenstored_logging Warn key
938 +let error key = xenstored_logging Error key
939
940 -let log_read_ops = ref false
941 -let log_transaction_ops = ref false
942 -let log_special_ops = ref false
943 +(* Access logger *)
944
945 type access_type =
946 | Coalesce
947 @@ -41,38 +142,10 @@
948 | Endconn
949 | XbOp of Xenbus.Xb.Op.operation
950
951 -type access =
952 - {
953 - fd: out_channel ref;
954 - counter: int ref;
955 - write: tid:int -> con:string -> ?data:string -> access_type -> unit;
956 - }
957 -
958 -let string_of_date () =
959 - let time = Unix.gettimeofday () in
960 - let tm = Unix.localtime time in
961 - let msec = time -. (floor time) in
962 - sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d" (1900 + tm.Unix.tm_year)
963 - (tm.Unix.tm_mon + 1)
964 - tm.Unix.tm_mday
965 - tm.Unix.tm_hour
966 - tm.Unix.tm_min
967 - tm.Unix.tm_sec
968 - (int_of_float (1000.0 *. msec))
969 -
970 -let fill_with_space n s =
971 - if String.length s < n
972 - then
973 - let r = String.make n ' ' in
974 - String.blit s 0 r 0 (String.length s);
975 - r
976 - else
977 - s
978 -
979 let string_of_tid ~con tid =
980 if tid = 0
981 - then fill_with_space 12 (sprintf "%s" con)
982 - else fill_with_space 12 (sprintf "%s.%i" con tid)
983 + then sprintf "%-12s" con
984 + else sprintf "%-12s" (sprintf "%s.%i" con tid)
985
986 let string_of_access_type = function
987 | Coalesce -> "coalesce "
988 @@ -109,41 +182,9 @@
989
990 | Xenbus.Xb.Op.Error -> "error "
991 | Xenbus.Xb.Op.Watchevent -> "w event "
992 -
993 + (*
994 | x -> Xenbus.Xb.Op.to_string x
995 -
996 -let file_exists file =
997 - try
998 - Unix.close (Unix.openfile file [Unix.O_RDONLY] 0o644);
999 - true
1000 - with _ ->
1001 - false
1002 -
1003 -let log_rotate fd =
1004 - let file n = sprintf "%s.%i" !access_log_file n in
1005 - let log_files =
1006 - let rec aux accu n =
1007 - if n >= !access_log_nb_files
1008 - then accu
1009 - else if n = 1 && file_exists !access_log_file
1010 - then aux [!access_log_file,1] 2
1011 - else
1012 - let file = file (n-1) in
1013 - if file_exists file
1014 - then aux ((file,n) :: accu) (n+1)
1015 - else accu
1016 - in
1017 - aux [] 1
1018 - in
1019 - let rec rename = function
1020 - | (f,n) :: t when n < !access_log_nb_files ->
1021 - Unix.rename f (file n);
1022 - rename t
1023 - | _ -> ()
1024 - in
1025 - rename log_files;
1026 - close_out !fd;
1027 - fd := open_out !access_log_file
1028 + *)
1029
1030 let sanitize_data data =
1031 let data = String.copy data in
1032 @@ -154,86 +195,68 @@
1033 done;
1034 String.escaped data
1035
1036 -let make save_to_disk =
1037 - let fd = ref (open_out_gen [Open_append; Open_creat] 0o644 !access_log_file) in
1038 - let counter = ref 0 in
1039 - {
1040 - fd = fd;
1041 - counter = counter;
1042 - write =
1043 - if not !activate_access_log || !access_log_nb_files = 0
1044 - then begin fun ~tid ~con ?data _ -> () end
1045 - else fun ~tid ~con ?(data="") access_type ->
1046 - let s = Printf.sprintf "[%s] %s %s %s\n" (string_of_date()) (string_of_tid ~con tid)
1047 - (string_of_access_type access_type) (sanitize_data data) in
1048 - let s =
1049 - if String.length s > line_size
1050 - then begin
1051 - let s = String.sub s 0 line_size in
1052 - s.[line_size-3] <- '.';
1053 - s.[line_size-2] <- '.';
1054 - s.[line_size-1] <- '\n';
1055 - s
1056 - end else
1057 - s
1058 - in
1059 - incr counter;
1060 - output_string !fd s;
1061 - flush !fd;
1062 - if !counter > !access_log_nb_lines
1063 - then begin
1064 - log_rotate fd;
1065 - save_to_disk ();
1066 - counter := 0;
1067 - end
1068 - }
1069 -
1070 -let access : (access option) ref = ref None
1071 -let init aal save_to_disk =
1072 - activate_access_log := aal;
1073 - access := Some (make save_to_disk)
1074 -
1075 -let write_access_log ~con ~tid ?data access_type =
1076 +let activate_access_log = ref true
1077 +let access_log_file = ref "/var/log/xenstored-access.log"
1078 +let access_log_nb_files = ref 20
1079 +let access_log_nb_lines = ref 13215
1080 +let access_log_nb_chars = ref 180
1081 +let access_log_read_ops = ref false
1082 +let access_log_transaction_ops = ref false
1083 +let access_log_special_ops = ref false
1084 +let access_logger = ref None
1085 +
1086 +let init_access_log post_rotate =
1087 + if !access_log_nb_files > 0 then
1088 + let logger =
1089 + make_logger
1090 + !access_log_file !access_log_nb_files !access_log_nb_lines
1091 + !access_log_nb_chars post_rotate in
1092 + access_logger := Some logger
1093 +
1094 +let access_logging ~con ~tid ?(data="") access_type =
1095 try
1096 - maybe (fun a -> a.write access_type ~con ~tid ?data) !access
1097 + maybe
1098 + (fun logger ->
1099 + let date = string_of_date() in
1100 + let tid = string_of_tid ~con tid in
1101 + let access_type = string_of_access_type access_type in
1102 + let data = sanitize_data data in
1103 + logger.write "[%s] %s %s %s" date tid access_type data)
1104 + !access_logger
1105 with _ -> ()
1106
1107 -let new_connection = write_access_log Newconn
1108 -let end_connection = write_access_log Endconn
1109 +let new_connection = access_logging Newconn
1110 +let end_connection = access_logging Endconn
1111 let read_coalesce ~tid ~con data =
1112 - if !log_read_ops
1113 - then write_access_log Coalesce ~tid ~con ~data:("read "^data)
1114 -let write_coalesce data = write_access_log Coalesce ~data:("write "^data)
1115 -let conflict = write_access_log Conflict
1116 -let commit = write_access_log Commit
1117 + if !access_log_read_ops
1118 + then access_logging Coalesce ~tid ~con ~data:("read "^data)
1119 +let write_coalesce data = access_logging Coalesce ~data:("write "^data)
1120 +let conflict = access_logging Conflict
1121 +let commit = access_logging Commit
1122
1123 let xb_op ~tid ~con ~ty data =
1124 - let print =
1125 - match ty with
1126 - | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !log_read_ops
1127 + let print = match ty with
1128 + | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops
1129 | Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end ->
1130 false (* transactions are managed below *)
1131 | Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume ->
1132 - !log_special_ops
1133 - | _ -> true
1134 - in
1135 - if print
1136 - then write_access_log ~tid ~con ~data (XbOp ty)
1137 + !access_log_special_ops
1138 + | _ -> true in
1139 + if print then access_logging ~tid ~con ~data (XbOp ty)
1140
1141 let start_transaction ~tid ~con =
1142 - if !log_transaction_ops && tid <> 0
1143 - then write_access_log ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start)
1144 + if !access_log_transaction_ops && tid <> 0
1145 + then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start)
1146
1147 let end_transaction ~tid ~con =
1148 - if !log_transaction_ops && tid <> 0
1149 - then write_access_log ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end)
1150 + if !access_log_transaction_ops && tid <> 0
1151 + then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end)
1152
1153 let xb_answer ~tid ~con ~ty data =
1154 let print = match ty with
1155 - | Xenbus.Xb.Op.Error when data="ENOENT " -> !log_read_ops
1156 - | Xenbus.Xb.Op.Error -> !log_special_ops
1157 + | Xenbus.Xb.Op.Error when String.startswith "ENOENT " data -> !access_log_read_ops
1158 + | Xenbus.Xb.Op.Error -> true
1159 | Xenbus.Xb.Op.Watchevent -> true
1160 | _ -> false
1161 in
1162 - if print
1163 - then write_access_log ~tid ~con ~data (XbOp ty)
1164 + if print then access_logging ~tid ~con ~data (XbOp ty)
1165 --- a/tools/ocaml/xenstored/perms.ml
1166 +++ b/tools/ocaml/xenstored/perms.ml
1167 @@ -15,6 +15,8 @@
1168 * GNU Lesser General Public License for more details.
1169 *)
1170
1171 +let info fmt = Logging.info "perms" fmt
1172 +
1173 open Stdext
1174
1175 let activate = ref true
1176 @@ -145,16 +147,16 @@
1177 in
1178 match perm, request with
1179 | NONE, _ ->
1180 - Logs.info "io" "Permission denied: Domain %d has no permission" domainid;
1181 + info "Permission denied: Domain %d has no permission" domainid;
1182 false
1183 | RDWR, _ -> true
1184 | READ, READ -> true
1185 | WRITE, WRITE -> true
1186 | READ, _ ->
1187 - Logs.info "io" "Permission denied: Domain %d has read only access" domainid;
1188 + info "Permission denied: Domain %d has read only access" domainid;
1189 false
1190 | WRITE, _ ->
1191 - Logs.info "io" "Permission denied: Domain %d has write only access" domainid;
1192 + info "Permission denied: Domain %d has write only access" domainid;
1193 false
1194 in
1195 if !activate
1196 --- a/tools/ocaml/xenstored/process.ml
1197 +++ b/tools/ocaml/xenstored/process.ml
1198 @@ -14,6 +14,9 @@
1199 * GNU Lesser General Public License for more details.
1200 *)
1201
1202 +let error fmt = Logging.error "process" fmt
1203 +let info fmt = Logging.info "process" fmt
1204 +
1205 open Printf
1206 open Stdext
1207
1208 @@ -79,7 +82,7 @@
1209
1210 (* packets *)
1211 let do_debug con t domains cons data =
1212 - if not !allow_debug
1213 + if not (Connection.is_dom0 con) && not !allow_debug
1214 then None
1215 else try match split None '\000' data with
1216 | "print" :: msg :: _ ->
1217 @@ -89,6 +92,9 @@
1218 let domid = int_of_string domid in
1219 let quota = (Store.get_quota t.Transaction.store) in
1220 Some (Quota.to_string quota domid ^ "\000")
1221 + | "watches" :: _ ->
1222 + let watches = Connections.debug cons in
1223 + Some (watches ^ "\000")
1224 | "mfn" :: domid :: _ ->
1225 let domid = int_of_string domid in
1226 let con = Connections.find_domain cons domid in
1227 @@ -357,8 +363,7 @@
1228 in
1229 input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data;
1230 with exn ->
1231 - Logs.error "general" "process packet: %s"
1232 - (Printexc.to_string exn);
1233 + error "process packet: %s" (Printexc.to_string exn);
1234 Connection.send_error con tid rid "EIO"
1235
1236 let write_access_log ~ty ~tid ~con ~data =
1237 @@ -372,7 +377,7 @@
1238 let packet = Connection.pop_in con in
1239 let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in
1240 (* As we don't log IO, do not call an unnecessary sanitize_data
1241 - Logs.info "io" "[%s] -> [%d] %s \"%s\""
1242 + info "[%s] -> [%d] %s \"%s\""
1243 (Connection.get_domstr con) tid
1244 (Xenbus.Xb.Op.to_string ty) (sanitize_data data); *)
1245 process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data;
1246 @@ -386,7 +391,7 @@
1247 let packet = Connection.peek_output con in
1248 let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in
1249 (* As we don't log IO, do not call an unnecessary sanitize_data
1250 - Logs.info "io" "[%s] <- %s \"%s\""
1251 + info "[%s] <- %s \"%s\""
1252 (Connection.get_domstr con)
1253 (Xenbus.Xb.Op.to_string ty) (sanitize_data data);*)
1254 write_answer_log ~ty ~tid ~con ~data;
1255 --- a/tools/ocaml/xenstored/quota.ml
1256 +++ b/tools/ocaml/xenstored/quota.ml
1257 @@ -18,7 +18,7 @@
1258 exception Data_too_big
1259 exception Transaction_opened
1260
1261 -let warn fmt = Logs.warn "general" fmt
1262 +let warn fmt = Logging.warn "quota" fmt
1263 let activate = ref true
1264 let maxent = ref (10000)
1265 let maxsize = ref (4096)
1266 --- a/tools/ocaml/xenstored/store.ml
1267 +++ b/tools/ocaml/xenstored/store.ml
1268 @@ -83,7 +83,7 @@
1269 let check_owner node connection =
1270 if not (Perms.check_owner connection node.perms)
1271 then begin
1272 - Logs.info "io" "Permission denied: Domain %d not owner" (get_owner node);
1273 + Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node);
1274 raise Define.Permission_denied;
1275 end
1276
1277 --- a/tools/ocaml/xenstored/xenstored.conf
1278 +++ b/tools/ocaml/xenstored/xenstored.conf
1279 @@ -22,9 +22,14 @@
1280 # Activate filed base backend
1281 persistant = false
1282
1283 -# Logs
1284 -log = error;general;file:/var/log/xenstored.log
1285 -log = warn;general;file:/var/log/xenstored.log
1286 -log = info;general;file:/var/log/xenstored.log
1287 +# Xenstored logs
1288 +# xenstored-log-file = /var/log/xenstored.log
1289 +# xenstored-log-level = null
1290 +# xenstored-log-nb-files = 10
1291 +
1292 +# Xenstored access logs
1293 +# access-log-file = /var/log/xenstored-access.log
1294 +# access-log-nb-lines = 13215
1295 +# acesss-log-nb-chars = 180
1296 +# access-log-special-ops = false
1297
1298 -# log = debug;io;file:/var/log/xenstored-io.log
1299 --- a/tools/ocaml/xenstored/xenstored.ml
1300 +++ b/tools/ocaml/xenstored/xenstored.ml
1301 @@ -18,7 +18,10 @@
1302 open Printf
1303 open Parse_arg
1304 open Stdext
1305 -open Logging
1306 +
1307 +let error fmt = Logging.error "xenstored" fmt
1308 +let debug fmt = Logging.debug "xenstored" fmt
1309 +let info fmt = Logging.info "xenstored" fmt
1310
1311 (*------------ event klass processors --------------*)
1312 let process_connection_fds store cons domains rset wset =
1313 @@ -64,7 +67,8 @@
1314 ()
1315
1316 let sighup_handler _ =
1317 - try Logs.reopen (); info "Log re-opened" with _ -> ()
1318 + maybe (fun logger -> logger.Logging.restart()) !Logging.xenstored_logger;
1319 + maybe (fun logger -> logger.Logging.restart()) !Logging.access_logger
1320
1321 let config_filename cf =
1322 match cf.config_file with
1323 @@ -75,26 +79,6 @@
1324
1325 let parse_config filename =
1326 let pidfile = ref default_pidfile in
1327 - let set_log s =
1328 - let ls = String.split ~limit:3 ';' s in
1329 - let level, key, logger = match ls with
1330 - | [ level; key; logger ] -> level, key, logger
1331 - | _ -> failwith "format mismatch: expecting 3 arguments" in
1332 -
1333 - let loglevel = match level with
1334 - | "debug" -> Log.Debug
1335 - | "info" -> Log.Info
1336 - | "warn" -> Log.Warn
1337 - | "error" -> Log.Error
1338 - | s -> failwith (sprintf "Unknown log level: %s" s) in
1339 -
1340 - (* if key is empty, append to the default logger *)
1341 - let append =
1342 - if key = "" then
1343 - Logs.append_default
1344 - else
1345 - Logs.append key in
1346 - append loglevel logger in
1347 let options = [
1348 ("merge-activate", Config.Set_bool Transaction.do_coalesce);
1349 ("perms-activate", Config.Set_bool Perms.activate);
1350 @@ -104,14 +88,20 @@
1351 ("quota-maxentity", Config.Set_int Quota.maxent);
1352 ("quota-maxsize", Config.Set_int Quota.maxsize);
1353 ("test-eagain", Config.Set_bool Transaction.test_eagain);
1354 - ("log", Config.String set_log);
1355 ("persistant", Config.Set_bool Disk.enable);
1356 + ("xenstored-log-file", Config.Set_string Logging.xenstored_log_file);
1357 + ("xenstored-log-level", Config.String
1358 + (fun s -> Logging.xenstored_log_level := Logging.level_of_string s));
1359 + ("xenstored-log-nb-files", Config.Set_int Logging.xenstored_log_nb_files);
1360 + ("xenstored-log-nb-lines", Config.Set_int Logging.xenstored_log_nb_lines);
1361 + ("xenstored-log-nb-chars", Config.Set_int Logging.xenstored_log_nb_chars);
1362 ("access-log-file", Config.Set_string Logging.access_log_file);
1363 ("access-log-nb-files", Config.Set_int Logging.access_log_nb_files);
1364 ("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines);
1365 - ("access-log-read-ops", Config.Set_bool Logging.log_read_ops);
1366 - ("access-log-transactions-ops", Config.Set_bool Logging.log_transaction_ops);
1367 - ("access-log-special-ops", Config.Set_bool Logging.log_special_ops);
1368 + ("access-log-nb-chars", Config.Set_int Logging.access_log_nb_chars);
1369 + ("access-log-read-ops", Config.Set_bool Logging.access_log_read_ops);
1370 + ("access-log-transactions-ops", Config.Set_bool Logging.access_log_transaction_ops);
1371 + ("access-log-special-ops", Config.Set_bool Logging.access_log_special_ops);
1372 ("allow-debug", Config.Set_bool Process.allow_debug);
1373 ("pid-file", Config.Set_string pidfile); ] in
1374 begin try Config.read filename options (fun _ _ -> raise Not_found)
1375 @@ -223,9 +213,6 @@
1376 end
1377
1378 let _ =
1379 - printf "Xen Storage Daemon, version %d.%d\n%!"
1380 - Define.xenstored_major Define.xenstored_minor;
1381 -
1382 let cf = do_argv in
1383 let pidfile =
1384 if Sys.file_exists (config_filename cf) then
1385 @@ -249,13 +236,13 @@
1386 in
1387
1388 if cf.daemonize then
1389 - Unixext.daemonize ();
1390 + Unixext.daemonize ()
1391 + else
1392 + printf "Xen Storage Daemon, version %d.%d\n%!"
1393 + Define.xenstored_major Define.xenstored_minor;
1394
1395 (try Unixext.pidfile_write pidfile with _ -> ());
1396
1397 - info "Xen Storage Daemon, version %d.%d"
1398 - Define.xenstored_major Define.xenstored_minor;
1399 -
1400 (* for compatilibity with old xenstored *)
1401 begin match cf.pidfile with
1402 | Some pidfile -> Unixext.pidfile_write pidfile
1403 @@ -293,7 +280,14 @@
1404 Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun i -> sigusr1_handler store));
1405 Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
1406
1407 - Logging.init cf.activate_access_log (fun () -> DB.to_file store cons "/var/run/xenstored/db");
1408 + Logging.init_xenstored_log();
1409 + if cf.activate_access_log then begin
1410 + let post_rotate () = DB.to_file store cons "/var/run/xenstored/db" in
1411 + Logging.init_access_log post_rotate
1412 + end;
1413 +
1414 + info "Xen Storage Daemon, version %d.%d"
1415 + Define.xenstored_major Define.xenstored_minor;
1416
1417 let spec_fds =
1418 (match rw_sock with None -> [] | Some x -> [ x ]) @
1419 --- a/tools/ocaml/libs/log/syslog.mli
1420 +++ /dev/null
1421 @@ -1,41 +0,0 @@
1422 -(*
1423 - * Copyright (C) 2006-2007 XenSource Ltd.
1424 - * Copyright (C) 2008 Citrix Ltd.
1425 - * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
1426 - *
1427 - * This program is free software; you can redistribute it and/or modify
1428 - * it under the terms of the GNU Lesser General Public License as published
1429 - * by the Free Software Foundation; version 2.1 only. with the special
1430 - * exception on linking described in file LICENSE.
1431 - *
1432 - * This program is distributed in the hope that it will be useful,
1433 - * but WITHOUT ANY WARRANTY; without even the implied warranty of
1434 - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1435 - * GNU Lesser General Public License for more details.
1436 - *)
1437 -
1438 -type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
1439 -type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
1440 -type facility =
1441 - Auth
1442 - | Authpriv
1443 - | Cron
1444 - | Daemon
1445 - | Ftp
1446 - | Kern
1447 - | Local0
1448 - | Local1
1449 - | Local2
1450 - | Local3
1451 - | Local4
1452 - | Local5
1453 - | Local6
1454 - | Local7
1455 - | Lpr
1456 - | Mail
1457 - | News
1458 - | Syslog
1459 - | User
1460 - | Uucp
1461 -external log : facility -> level -> string -> unit = "stub_syslog"
1462 -external close : unit -> unit = "stub_closelog"
1463 --- a/tools/ocaml/libs/log/Makefile
1464 +++ /dev/null
1465 @@ -1,44 +0,0 @@
1466 -TOPLEVEL=$(CURDIR)/../..
1467 -XEN_ROOT=$(TOPLEVEL)/../..
1468 -include $(TOPLEVEL)/common.make
1469 -
1470 -OBJS = syslog log logs
1471 -INTF = log.cmi logs.cmi syslog.cmi
1472 -LIBS = log.cma log.cmxa
1473 -
1474 -all: $(INTF) $(LIBS) $(PROGRAMS)
1475 -
1476 -bins: $(PROGRAMS)
1477 -
1478 -libs: $(LIBS)
1479 -
1480 -log.cmxa: libsyslog_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
1481 - $(call mk-caml-lib-native, $@, -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmx))
1482 -
1483 -log.cma: $(foreach obj,$(OBJS),$(obj).cmo)
1484 - $(call mk-caml-lib-bytecode, $@, -dllib dllsyslog_stubs.so -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmo))
1485 -
1486 -syslog_stubs.a: syslog_stubs.o
1487 - $(call mk-caml-stubs, $@, $+)
1488 -
1489 -libsyslog_stubs.a: syslog_stubs.o
1490 - $(call mk-caml-lib-stubs, $@, $+)
1491 -
1492 -logs.mli : logs.ml
1493 - $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@
1494 -
1495 -syslog.mli : syslog.ml
1496 - $(OCAMLC) -i $< > $@
1497 -
1498 -.PHONY: install
1499 -install: $(LIBS) META
1500 - mkdir -p $(OCAMLDESTDIR)
1501 - ocamlfind remove -destdir $(OCAMLDESTDIR) log
1502 - ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx
1503 -
1504 -.PHONY: uninstall
1505 -uninstall:
1506 - ocamlfind remove -destdir $(OCAMLDESTDIR) log
1507 -
1508 -include $(TOPLEVEL)/Makefile.rules
1509 -