mirror of
https://github.com/xen-project/xen.git
synced 2026-10-28 10:11:27 +01:00
tools/ocaml: Remove log library from tools/ocaml/libs
The only user was oxenstored, which has had the relevant bits merged in. Signed-off-by: Zheng Li <zheng.li@eu.citrix.com> Acked-by: Ian Campbell <ian.campbell.com> Committed-by: Ian Jackson <ian.jackson.citrix.com> Acked-by: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
This commit is contained in:
1 parent
cc3739d41c
commit
c69fddbd5d
23 files changed
+235
-943
No files matched your search
@@ -3,7 +3,7 @@ include $(XEN_ROOT)/tools/Rules.mk
|
||||
|
||||
SUBDIRS= \
|
||||
mmap \
|
||||
log xc eventchn \
|
||||
xc eventchn \
|
||||
xb xs xl
|
||||
|
||||
.PHONY: all
|
||||
|
||||
@@ -1,5 +0,0 @@
|
||||
version = "@VERSION@"
|
||||
description = "Log - logging library"
|
||||
requires = "unix"
|
||||
archive(byte) = "log.cma"
|
||||
archive(native) = "log.cmxa"
|
||||
@@ -1,44 +0,0 @@
|
||||
TOPLEVEL=$(CURDIR)/../..
|
||||
XEN_ROOT=$(TOPLEVEL)/../..
|
||||
include $(TOPLEVEL)/common.make
|
||||
|
||||
OBJS = syslog log logs
|
||||
INTF = log.cmi logs.cmi syslog.cmi
|
||||
LIBS = log.cma log.cmxa
|
||||
|
||||
all: $(INTF) $(LIBS) $(PROGRAMS)
|
||||
|
||||
bins: $(PROGRAMS)
|
||||
|
||||
libs: $(LIBS)
|
||||
|
||||
log.cmxa: libsyslog_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
|
||||
$(call mk-caml-lib-native, $@, -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmx))
|
||||
|
||||
log.cma: $(foreach obj,$(OBJS),$(obj).cmo)
|
||||
$(call mk-caml-lib-bytecode, $@, -dllib dllsyslog_stubs.so -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmo))
|
||||
|
||||
syslog_stubs.a: syslog_stubs.o
|
||||
$(call mk-caml-stubs, $@, $+)
|
||||
|
||||
libsyslog_stubs.a: syslog_stubs.o
|
||||
$(call mk-caml-lib-stubs, $@, $+)
|
||||
|
||||
logs.mli : logs.ml
|
||||
$(OCAMLC) -i $(OCAMLCFLAGS) $< > $@
|
||||
|
||||
syslog.mli : syslog.ml
|
||||
$(OCAMLC) -i $< > $@
|
||||
|
||||
.PHONY: install
|
||||
install: $(LIBS) META
|
||||
mkdir -p $(OCAMLDESTDIR)
|
||||
ocamlfind remove -destdir $(OCAMLDESTDIR) log
|
||||
ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx
|
||||
|
||||
.PHONY: uninstall
|
||||
uninstall:
|
||||
ocamlfind remove -destdir $(OCAMLDESTDIR) log
|
||||
|
||||
include $(TOPLEVEL)/Makefile.rules
|
||||
|
||||
@@ -1,258 +0,0 @@
|
||||
(*
|
||||
* Copyright (C) 2006-2007 XenSource Ltd.
|
||||
* Copyright (C) 2008 Citrix Ltd.
|
||||
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published
|
||||
* by the Free Software Foundation; version 2.1 only. with the special
|
||||
* exception on linking described in file LICENSE.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
open Printf
|
||||
|
||||
exception Unknown_level of string
|
||||
|
||||
type stream_type = Stderr | Stdout | File of string
|
||||
|
||||
type stream_log = {
|
||||
ty : stream_type;
|
||||
channel : out_channel option ref;
|
||||
}
|
||||
|
||||
type level = Debug | Info | Warn | Error
|
||||
|
||||
type output =
|
||||
| Stream of stream_log
|
||||
| String of string list ref
|
||||
| Syslog of string
|
||||
| Nil
|
||||
|
||||
let int_of_level l =
|
||||
match l with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3
|
||||
|
||||
let string_of_level l =
|
||||
match l with Debug -> "debug" | Info -> "info"
|
||||
| Warn -> "warn" | Error -> "error"
|
||||
|
||||
let level_of_string s =
|
||||
match s with
|
||||
| "debug" -> Debug
|
||||
| "info" -> Info
|
||||
| "warn" -> Warn
|
||||
| "error" -> Error
|
||||
| _ -> raise (Unknown_level s)
|
||||
|
||||
let mkdir_safe dir perm =
|
||||
try Unix.mkdir dir perm with _ -> ()
|
||||
|
||||
let mkdir_rec dir perm =
|
||||
let rec p_mkdir dir =
|
||||
let p_name = Filename.dirname dir in
|
||||
if p_name = "/" || p_name = "." then
|
||||
()
|
||||
else (
|
||||
p_mkdir p_name;
|
||||
mkdir_safe dir perm
|
||||
) in
|
||||
p_mkdir dir
|
||||
|
||||
type t = { output: output; mutable level: level; }
|
||||
|
||||
let make output level = { output = output; level = level; }
|
||||
|
||||
let make_stream ty channel =
|
||||
Stream {ty=ty; channel=ref channel; }
|
||||
|
||||
(** open a syslog logger *)
|
||||
let opensyslog k level =
|
||||
make (Syslog k) level
|
||||
|
||||
(** open a stderr logger *)
|
||||
let openerr level =
|
||||
if (Unix.stat "/dev/stderr").Unix.st_kind <> Unix.S_CHR then
|
||||
failwith "/dev/stderr is not a valid character device";
|
||||
make (make_stream Stderr (Some (open_out "/dev/stderr"))) level
|
||||
|
||||
let openout level =
|
||||
if (Unix.stat "/dev/stdout").Unix.st_kind <> Unix.S_CHR then
|
||||
failwith "/dev/stdout is not a valid character device";
|
||||
make (make_stream Stdout (Some (open_out "/dev/stdout"))) level
|
||||
|
||||
|
||||
(** open a stream logger - returning the channel. *)
|
||||
(* This needs to be separated from 'openfile' so we can reopen later *)
|
||||
let doopenfile filename =
|
||||
if Filename.is_relative filename then
|
||||
None
|
||||
else (
|
||||
try
|
||||
mkdir_rec (Filename.dirname filename) 0o700;
|
||||
Some (open_out_gen [ Open_append; Open_creat ] 0o600 filename)
|
||||
with _ -> None
|
||||
)
|
||||
|
||||
(** open a stream logger - returning the output type *)
|
||||
let openfile filename level =
|
||||
make (make_stream (File filename) (doopenfile filename)) level
|
||||
|
||||
(** open a nil logger *)
|
||||
let opennil () =
|
||||
make Nil Error
|
||||
|
||||
(** open a string logger *)
|
||||
let openstring level =
|
||||
make (String (ref [""])) level
|
||||
|
||||
(** try to reopen a logger *)
|
||||
let reopen t =
|
||||
match t.output with
|
||||
| Nil -> t
|
||||
| Syslog k -> Syslog.close (); opensyslog k t.level
|
||||
| Stream s -> (
|
||||
match (s.ty,!(s.channel)) with
|
||||
| (File filename, Some c) -> close_out c; s.channel := (try doopenfile filename with _ -> None); t
|
||||
| _ -> t)
|
||||
| String _ -> t
|
||||
|
||||
(** close a logger *)
|
||||
let close t =
|
||||
match t.output with
|
||||
| Nil -> ()
|
||||
| Syslog k -> Syslog.close ();
|
||||
| Stream s -> (
|
||||
match !(s.channel) with
|
||||
| Some c -> close_out c; s.channel := None
|
||||
| None -> ())
|
||||
| String _ -> ()
|
||||
|
||||
(** create a string representating the parameters of the logger *)
|
||||
let string_of_logger t =
|
||||
match t.output with
|
||||
| Nil -> "nil"
|
||||
| Syslog k -> sprintf "syslog:%s" k
|
||||
| String _ -> "string"
|
||||
| Stream s ->
|
||||
begin
|
||||
match s.ty with
|
||||
| File f -> sprintf "file:%s" f
|
||||
| Stderr -> "stderr"
|
||||
| Stdout -> "stdout"
|
||||
end
|
||||
|
||||
(** parse a string to a logger *)
|
||||
let logger_of_string s : t =
|
||||
match s with
|
||||
| "nil" -> opennil ()
|
||||
| "stderr" -> openerr Debug
|
||||
| "stdout" -> openout Debug
|
||||
| "string" -> openstring Debug
|
||||
| _ ->
|
||||
let split_in_2 s =
|
||||
try
|
||||
let i = String.index s ':' in
|
||||
String.sub s 0 (i),
|
||||
String.sub s (i + 1) (String.length s - i - 1)
|
||||
with _ ->
|
||||
failwith "logger format error: expecting string:string"
|
||||
in
|
||||
let k, s = split_in_2 s in
|
||||
match k with
|
||||
| "syslog" -> opensyslog s Debug
|
||||
| "file" -> openfile s Debug
|
||||
| _ -> failwith "unknown logger type"
|
||||
|
||||
let validate s =
|
||||
match s with
|
||||
| "nil" -> ()
|
||||
| "stderr" -> ()
|
||||
| "stdout" -> ()
|
||||
| "string" -> ()
|
||||
| _ ->
|
||||
let split_in_2 s =
|
||||
try
|
||||
let i = String.index s ':' in
|
||||
String.sub s 0 (i),
|
||||
String.sub s (i + 1) (String.length s - i - 1)
|
||||
with _ ->
|
||||
failwith "logger format error: expecting string:string"
|
||||
in
|
||||
let k, s = split_in_2 s in
|
||||
match k with
|
||||
| "syslog" -> ()
|
||||
| "file" -> (
|
||||
try
|
||||
let st = Unix.stat s in
|
||||
if st.Unix.st_kind <> Unix.S_REG then
|
||||
failwith "logger file is a directory";
|
||||
()
|
||||
with Unix.Unix_error (Unix.ENOENT, _, _) -> ()
|
||||
)
|
||||
| _ -> failwith "unknown logger"
|
||||
|
||||
(** change a logger level to level *)
|
||||
let set t level = t.level <- level
|
||||
|
||||
let gettimestring () =
|
||||
let time = Unix.gettimeofday () in
|
||||
let tm = Unix.localtime time in
|
||||
let msec = time -. (floor time) in
|
||||
sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d|" (1900 + tm.Unix.tm_year)
|
||||
(tm.Unix.tm_mon + 1) tm.Unix.tm_mday
|
||||
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
|
||||
(int_of_float (1000.0 *. msec))
|
||||
|
||||
(*let extra_hook = ref (fun x -> x)*)
|
||||
|
||||
let output t ?(key="") ?(extra="") priority (message: string) =
|
||||
let construct_string withtime =
|
||||
(*let key = if key = "" then [] else [ key ] in
|
||||
let extra = if extra = "" then [] else [ extra ] in
|
||||
let items =
|
||||
(if withtime then [ gettimestring () ] else [])
|
||||
@ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ message ] in
|
||||
(* let items = !extra_hook items in*)
|
||||
String.concat " " items*)
|
||||
Printf.sprintf "[%s%s|%s] %s"
|
||||
(if withtime then gettimestring () else "") (string_of_level priority) extra message
|
||||
in
|
||||
(* Keep track of how much we write out to streams, so that we can *)
|
||||
(* log-rotate at appropriate times *)
|
||||
let write_to_stream stream =
|
||||
let string = (construct_string true) in
|
||||
try
|
||||
fprintf stream "%s\n%!" string
|
||||
with _ -> () (* Trap exception when we fail to write log *)
|
||||
in
|
||||
|
||||
if String.length message > 0 then
|
||||
match t.output with
|
||||
| Syslog k ->
|
||||
let sys_prio = match priority with
|
||||
| Debug -> Syslog.Debug
|
||||
| Info -> Syslog.Info
|
||||
| Warn -> Syslog.Warning
|
||||
| Error -> Syslog.Err in
|
||||
Syslog.log Syslog.Daemon sys_prio ((construct_string false) ^ "\n")
|
||||
| Stream s -> (
|
||||
match !(s.channel) with
|
||||
| Some c -> write_to_stream c
|
||||
| None -> ())
|
||||
| Nil -> ()
|
||||
| String s -> (s := (construct_string true)::!s)
|
||||
|
||||
let log t level (fmt: ('a, unit, string, unit) format4): 'a =
|
||||
let b = (int_of_level t.level) <= (int_of_level level) in
|
||||
(* ksprintf is the preferred name for kprintf, but the former
|
||||
* is not available in OCaml 3.08.3 *)
|
||||
Printf.kprintf (if b then output t level else (fun _ -> ())) fmt
|
||||
|
||||
let debug t (fmt: ('a , unit, string, unit) format4) = log t Debug fmt
|
||||
let info t (fmt: ('a , unit, string, unit) format4) = log t Info fmt
|
||||
let warn t (fmt: ('a , unit, string, unit) format4) = log t Warn fmt
|
||||
let error t (fmt: ('a , unit, string, unit) format4) = log t Error fmt
|
||||
@@ -1,55 +0,0 @@
|
||||
(*
|
||||
* Copyright (C) 2006-2007 XenSource Ltd.
|
||||
* Copyright (C) 2008 Citrix Ltd.
|
||||
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published
|
||||
* by the Free Software Foundation; version 2.1 only. with the special
|
||||
* exception on linking described in file LICENSE.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
exception Unknown_level of string
|
||||
type level = Debug | Info | Warn | Error
|
||||
|
||||
type stream_type = Stderr | Stdout | File of string
|
||||
type stream_log = {
|
||||
ty : stream_type;
|
||||
channel : out_channel option ref;
|
||||
}
|
||||
type output =
|
||||
Stream of stream_log
|
||||
| String of string list ref
|
||||
| Syslog of string
|
||||
| Nil
|
||||
val int_of_level : level -> int
|
||||
val string_of_level : level -> string
|
||||
val level_of_string : string -> level
|
||||
val mkdir_safe : string -> Unix.file_perm -> unit
|
||||
val mkdir_rec : string -> Unix.file_perm -> unit
|
||||
type t = { output : output; mutable level : level; }
|
||||
val make : output -> level -> t
|
||||
val opensyslog : string -> level -> t
|
||||
val openerr : level -> t
|
||||
val openout : level -> t
|
||||
val openfile : string -> level -> t
|
||||
val opennil : unit -> t
|
||||
val openstring : level -> t
|
||||
val reopen : t -> t
|
||||
val close : t -> unit
|
||||
val string_of_logger : t -> string
|
||||
val logger_of_string : string -> t
|
||||
val validate : string -> unit
|
||||
val set : t -> level -> unit
|
||||
val gettimestring : unit -> string
|
||||
val output : t -> ?key:string -> ?extra:string -> level -> string -> unit
|
||||
val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
|
||||
val debug : t -> ('a, unit, string, unit) format4 -> 'a
|
||||
val info : t -> ('a, unit, string, unit) format4 -> 'a
|
||||
val warn : t -> ('a, unit, string, unit) format4 -> 'a
|
||||
val error : t -> ('a, unit, string, unit) format4 -> 'a
|
||||
@@ -1,197 +0,0 @@
|
||||
(*
|
||||
* Copyright (C) 2006-2007 XenSource Ltd.
|
||||
* Copyright (C) 2008 Citrix Ltd.
|
||||
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published
|
||||
* by the Free Software Foundation; version 2.1 only. with the special
|
||||
* exception on linking described in file LICENSE.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
type keylogger =
|
||||
{
|
||||
mutable debug: string list;
|
||||
mutable info: string list;
|
||||
mutable warn: string list;
|
||||
mutable error: string list;
|
||||
no_default: bool;
|
||||
}
|
||||
|
||||
(* map all logger strings into a logger *)
|
||||
let __all_loggers = Hashtbl.create 10
|
||||
|
||||
(* default logger that everything that doesn't have a key in __lop_mapping get send *)
|
||||
let __default_logger = { debug = []; info = []; warn = []; error = []; no_default = false }
|
||||
|
||||
(*
|
||||
* This describe the mapping between a name to a keylogger.
|
||||
* a keylogger contains a list of logger string per level of debugging.
|
||||
* Example: "xenops", debug -> [ "stderr"; "/var/log/xensource.log" ]
|
||||
* "xapi", error -> []
|
||||
* "xapi", debug -> [ "/var/log/xensource.log" ]
|
||||
* "xenops", info -> [ "syslog" ]
|
||||
*)
|
||||
let __log_mapping = Hashtbl.create 32
|
||||
|
||||
let get_or_open logstring =
|
||||
if Hashtbl.mem __all_loggers logstring then
|
||||
Hashtbl.find __all_loggers logstring
|
||||
else
|
||||
let t = Log.logger_of_string logstring in
|
||||
Hashtbl.add __all_loggers logstring t;
|
||||
t
|
||||
|
||||
(** create a mapping entry for the key "name".
|
||||
* all log level of key "name" default to "logger" logger.
|
||||
* a sensible default is put "nil" as a logger and reopen a specific level to
|
||||
* the logger you want to.
|
||||
*)
|
||||
let add key logger =
|
||||
let kl = {
|
||||
debug = logger;
|
||||
info = logger;
|
||||
warn = logger;
|
||||
error = logger;
|
||||
no_default = false;
|
||||
} in
|
||||
Hashtbl.add __log_mapping key kl
|
||||
|
||||
let get_by_level keylog level =
|
||||
match level with
|
||||
| Log.Debug -> keylog.debug
|
||||
| Log.Info -> keylog.info
|
||||
| Log.Warn -> keylog.warn
|
||||
| Log.Error -> keylog.error
|
||||
|
||||
let set_by_level keylog level logger =
|
||||
match level with
|
||||
| Log.Debug -> keylog.debug <- logger
|
||||
| Log.Info -> keylog.info <- logger
|
||||
| Log.Warn -> keylog.warn <- logger
|
||||
| Log.Error -> keylog.error <- logger
|
||||
|
||||
(** set a specific key|level to the logger "logger" *)
|
||||
let set key level logger =
|
||||
if not (Hashtbl.mem __log_mapping key) then
|
||||
add key [];
|
||||
|
||||
let keylog = Hashtbl.find __log_mapping key in
|
||||
set_by_level keylog level logger
|
||||
|
||||
(** set default logger *)
|
||||
let set_default level logger =
|
||||
set_by_level __default_logger level logger
|
||||
|
||||
(** append a logger to the list *)
|
||||
let append key level logger =
|
||||
if not (Hashtbl.mem __log_mapping key) then
|
||||
add key [];
|
||||
let keylog = Hashtbl.find __log_mapping key in
|
||||
let loggers = get_by_level keylog level in
|
||||
set_by_level keylog level (loggers @ [ logger ])
|
||||
|
||||
(** append a logger to the default list *)
|
||||
let append_default level logger =
|
||||
let loggers = get_by_level __default_logger level in
|
||||
set_by_level __default_logger level (loggers @ [ logger ])
|
||||
|
||||
(** reopen all logger open *)
|
||||
let reopen () =
|
||||
Hashtbl.iter (fun k v ->
|
||||
Hashtbl.replace __all_loggers k (Log.reopen v)) __all_loggers
|
||||
|
||||
(** reclaim close all logger open that are not use by any other keys *)
|
||||
let reclaim () =
|
||||
let list_sort_uniq l =
|
||||
let oldprev = ref "" and prev = ref "" in
|
||||
List.fold_left (fun a k ->
|
||||
oldprev := !prev;
|
||||
prev := k;
|
||||
if k = !oldprev then a else k :: a) []
|
||||
(List.sort compare l)
|
||||
in
|
||||
let flatten_keylogger v =
|
||||
list_sort_uniq (v.debug @ v.info @ v.warn @ v.error) in
|
||||
let oldkeys = Hashtbl.fold (fun k v a -> k :: a) __all_loggers [] in
|
||||
let usedkeys = Hashtbl.fold (fun k v a ->
|
||||
(flatten_keylogger v) @ a)
|
||||
__log_mapping (flatten_keylogger __default_logger) in
|
||||
let usedkeys = list_sort_uniq usedkeys in
|
||||
|
||||
List.iter (fun k ->
|
||||
if not (List.mem k usedkeys) then (
|
||||
begin try
|
||||
Log.close (Hashtbl.find __all_loggers k)
|
||||
with
|
||||
Not_found -> ()
|
||||
end;
|
||||
Hashtbl.remove __all_loggers k
|
||||
)) oldkeys
|
||||
|
||||
(** clear a specific key|level *)
|
||||
let clear key level =
|
||||
try
|
||||
let keylog = Hashtbl.find __log_mapping key in
|
||||
set_by_level keylog level [];
|
||||
reclaim ()
|
||||
with Not_found ->
|
||||
()
|
||||
|
||||
(** clear a specific default level *)
|
||||
let clear_default level =
|
||||
set_default level [];
|
||||
reclaim ()
|
||||
|
||||
(** reset all the loggers to the specified logger *)
|
||||
let reset_all logger =
|
||||
Hashtbl.clear __log_mapping;
|
||||
set_default Log.Debug logger;
|
||||
set_default Log.Warn logger;
|
||||
set_default Log.Error logger;
|
||||
set_default Log.Info logger;
|
||||
reclaim ()
|
||||
|
||||
(** log a fmt message to the key|level logger specified in the log mapping.
|
||||
* if the logger doesn't exist, assume nil logger.
|
||||
*)
|
||||
let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a =
|
||||
let keylog =
|
||||
if Hashtbl.mem __log_mapping key then
|
||||
let keylog = Hashtbl.find __log_mapping key in
|
||||
if keylog.no_default = false &&
|
||||
get_by_level keylog level = [] then
|
||||
__default_logger
|
||||
else
|
||||
keylog
|
||||
else
|
||||
__default_logger in
|
||||
let loggers = get_by_level keylog level in
|
||||
match loggers with
|
||||
| [] -> Printf.kprintf ignore fmt
|
||||
| _ ->
|
||||
let l = List.fold_left (fun acc logger ->
|
||||
try get_or_open logger :: acc
|
||||
with _ -> acc
|
||||
) [] loggers in
|
||||
let l = List.rev l in
|
||||
|
||||
(* ksprintf is the preferred name for kprintf, but the former
|
||||
* is not available in OCaml 3.08.3 *)
|
||||
Printf.kprintf (fun s ->
|
||||
List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt
|
||||
|
||||
(* define some convenience functions *)
|
||||
let debug t ?extra (fmt: ('a , unit, string, unit) format4) =
|
||||
log t Log.Debug ?extra fmt
|
||||
let info t ?extra (fmt: ('a , unit, string, unit) format4) =
|
||||
log t Log.Info ?extra fmt
|
||||
let warn t ?extra (fmt: ('a , unit, string, unit) format4) =
|
||||
log t Log.Warn ?extra fmt
|
||||
let error t ?extra (fmt: ('a , unit, string, unit) format4) =
|
||||
log t Log.Error ?extra fmt
|
||||
@@ -1,46 +0,0 @@
|
||||
(*
|
||||
* Copyright (C) 2006-2007 XenSource Ltd.
|
||||
* Copyright (C) 2008 Citrix Ltd.
|
||||
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published
|
||||
* by the Free Software Foundation; version 2.1 only. with the special
|
||||
* exception on linking described in file LICENSE.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
type keylogger = {
|
||||
mutable debug : string list;
|
||||
mutable info : string list;
|
||||
mutable warn : string list;
|
||||
mutable error : string list;
|
||||
no_default : bool;
|
||||
}
|
||||
val __all_loggers : (string, Log.t) Hashtbl.t
|
||||
val __default_logger : keylogger
|
||||
val __log_mapping : (string, keylogger) Hashtbl.t
|
||||
val get_or_open : string -> Log.t
|
||||
val add : string -> string list -> unit
|
||||
val get_by_level : keylogger -> Log.level -> string list
|
||||
val set_by_level : keylogger -> Log.level -> string list -> unit
|
||||
val set : string -> Log.level -> string list -> unit
|
||||
val set_default : Log.level -> string list -> unit
|
||||
val append : string -> Log.level -> string -> unit
|
||||
val append_default : Log.level -> string -> unit
|
||||
val reopen : unit -> unit
|
||||
val reclaim : unit -> unit
|
||||
val clear : string -> Log.level -> unit
|
||||
val clear_default : Log.level -> unit
|
||||
val reset_all : string list -> unit
|
||||
val log :
|
||||
string ->
|
||||
Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
|
||||
val debug : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
|
||||
val info : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
|
||||
val warn : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
|
||||
val error : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
|
||||
@@ -1,26 +0,0 @@
|
||||
(*
|
||||
* Copyright (C) 2006-2007 XenSource Ltd.
|
||||
* Copyright (C) 2008 Citrix Ltd.
|
||||
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published
|
||||
* by the Free Software Foundation; version 2.1 only. with the special
|
||||
* exception on linking described in file LICENSE.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
|
||||
type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
|
||||
type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern
|
||||
| Local0 | Local1 | Local2 | Local3
|
||||
| Local4 | Local5 | Local6 | Local7
|
||||
| Lpr | Mail | News | Syslog | User | Uucp
|
||||
|
||||
(* external init : string -> options list -> facility -> unit = "stub_openlog" *)
|
||||
external log : facility -> level -> string -> unit = "stub_syslog"
|
||||
external close : unit -> unit = "stub_closelog"
|
||||
@@ -1,41 +0,0 @@
|
||||
(*
|
||||
* Copyright (C) 2006-2007 XenSource Ltd.
|
||||
* Copyright (C) 2008 Citrix Ltd.
|
||||
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published
|
||||
* by the Free Software Foundation; version 2.1 only. with the special
|
||||
* exception on linking described in file LICENSE.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
|
||||
type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
|
||||
type facility =
|
||||
Auth
|
||||
| Authpriv
|
||||
| Cron
|
||||
| Daemon
|
||||
| Ftp
|
||||
| Kern
|
||||
| Local0
|
||||
| Local1
|
||||
| Local2
|
||||
| Local3
|
||||
| Local4
|
||||
| Local5
|
||||
| Local6
|
||||
| Local7
|
||||
| Lpr
|
||||
| Mail
|
||||
| News
|
||||
| Syslog
|
||||
| User
|
||||
| Uucp
|
||||
external log : facility -> level -> string -> unit = "stub_syslog"
|
||||
external close : unit -> unit = "stub_closelog"
|
||||
@@ -1,75 +0,0 @@
|
||||
/*
|
||||
* Copyright (C) 2006-2007 XenSource Ltd.
|
||||
* Copyright (C) 2008 Citrix Ltd.
|
||||
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published
|
||||
* by the Free Software Foundation; version 2.1 only. with the special
|
||||
* exception on linking described in file LICENSE.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*/
|
||||
|
||||
#include <syslog.h>
|
||||
#include <caml/mlvalues.h>
|
||||
#include <caml/memory.h>
|
||||
#include <caml/alloc.h>
|
||||
#include <caml/custom.h>
|
||||
|
||||
static int __syslog_level_table[] = {
|
||||
LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING,
|
||||
LOG_NOTICE, LOG_INFO, LOG_DEBUG
|
||||
};
|
||||
|
||||
/*
|
||||
static int __syslog_options_table[] = {
|
||||
LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID
|
||||
};
|
||||
*/
|
||||
|
||||
static int __syslog_facility_table[] = {
|
||||
LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN,
|
||||
LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3,
|
||||
LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7,
|
||||
LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP
|
||||
};
|
||||
|
||||
/* According to the openlog manpage the 'openlog' call may take a reference
|
||||
to the 'ident' string and keep it long-term. This means we cannot just pass in
|
||||
an ocaml string which is under the control of the GC. Since we aren't actually
|
||||
calling this function we can just comment it out for the time-being. */
|
||||
/*
|
||||
value stub_openlog(value ident, value option, value facility)
|
||||
{
|
||||
CAMLparam3(ident, option, facility);
|
||||
int c_option;
|
||||
int c_facility;
|
||||
|
||||
c_option = caml_convert_flag_list(option, __syslog_options_table);
|
||||
c_facility = __syslog_facility_table[Int_val(facility)];
|
||||
openlog(String_val(ident), c_option, c_facility);
|
||||
CAMLreturn(Val_unit);
|
||||
}
|
||||
*/
|
||||
|
||||
value stub_syslog(value facility, value level, value msg)
|
||||
{
|
||||
CAMLparam3(facility, level, msg);
|
||||
int c_facility;
|
||||
|
||||
c_facility = __syslog_facility_table[Int_val(facility)]
|
||||
| __syslog_level_table[Int_val(level)];
|
||||
syslog(c_facility, "%s", String_val(msg));
|
||||
CAMLreturn(Val_unit);
|
||||
}
|
||||
|
||||
value stub_closelog(value unit)
|
||||
{
|
||||
CAMLparam1(unit);
|
||||
closelog();
|
||||
CAMLreturn(Val_unit);
|
||||
}
|
||||
@@ -3,7 +3,6 @@ OCAML_TOPLEVEL = $(CURDIR)/..
|
||||
include $(OCAML_TOPLEVEL)/common.make
|
||||
|
||||
OCAMLINCLUDE += \
|
||||
-I $(OCAML_TOPLEVEL)/libs/log \
|
||||
-I $(OCAML_TOPLEVEL)/libs/xb \
|
||||
-I $(OCAML_TOPLEVEL)/libs/mmap \
|
||||
-I $(OCAML_TOPLEVEL)/libs/xc \
|
||||
@@ -34,7 +33,6 @@ INTF = symbol.cmi trie.cmi
|
||||
XENSTOREDLIBS = \
|
||||
unix.cmxa \
|
||||
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \
|
||||
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/log $(OCAML_TOPLEVEL)/libs/log/log.cmxa \
|
||||
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \
|
||||
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \
|
||||
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xenbus.cmxa \
|
||||
|
||||
@@ -232,3 +232,8 @@ let dump con chan =
|
||||
Printf.fprintf chan "watch,%d,%s,%s\n" domid (Utils.hexify path) (Utils.hexify token)
|
||||
) (list_watches con);
|
||||
| None -> ()
|
||||
|
||||
let debug con =
|
||||
let domid = get_domstr con in
|
||||
let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in
|
||||
String.concat "" watches
|
||||
@@ -15,7 +15,7 @@
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
let debug fmt = Logs.debug "general" fmt
|
||||
let debug fmt = Logging.debug "connections" fmt
|
||||
|
||||
type t = {
|
||||
mutable anonymous: Connection.t list;
|
||||
@@ -165,3 +165,8 @@ let stats cons =
|
||||
);
|
||||
(List.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon,
|
||||
Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom)
|
||||
|
||||
let debug cons =
|
||||
let anonymous = List.map Connection.debug cons.anonymous in
|
||||
let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in
|
||||
String.concat "" (domains @ anonymous)
|
||||
@@ -17,7 +17,7 @@
|
||||
let enable = ref false
|
||||
let xs_daemon_database = "/var/run/xenstored/db"
|
||||
|
||||
let error = Logs.error "general"
|
||||
let error fmt = Logging.error "disk" fmt
|
||||
|
||||
(* unescape utils *)
|
||||
exception Bad_escape
|
||||
|
||||
@@ -16,7 +16,7 @@
|
||||
|
||||
open Printf
|
||||
|
||||
let debug fmt = Logs.debug "general" fmt
|
||||
let debug fmt = Logging.debug "domain" fmt
|
||||
|
||||
type t =
|
||||
{
|
||||
|
||||
@@ -14,6 +14,8 @@
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
let debug fmt = Logging.debug "domains" fmt
|
||||
|
||||
type domains = {
|
||||
eventchn: Event.t;
|
||||
table: (Xenctrl.domid, Domain.t) Hashtbl.t;
|
||||
@@ -35,7 +37,7 @@ let cleanup xc doms =
|
||||
try
|
||||
let info = Xenctrl.domain_getinfo xc id in
|
||||
if info.Xenctrl.shutdown || info.Xenctrl.dying then (
|
||||
Logs.debug "general" "Domain %u died (dying=%b, shutdown %b -- code %d)"
|
||||
debug "Domain %u died (dying=%b, shutdown %b -- code %d)"
|
||||
id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code;
|
||||
if info.Xenctrl.dying then
|
||||
dead_dom := id :: !dead_dom
|
||||
@@ -43,7 +45,7 @@ let cleanup xc doms =
|
||||
notify := true;
|
||||
)
|
||||
with Xenctrl.Error _ ->
|
||||
Logs.debug "general" "Domain %u died -- no domain info" id;
|
||||
debug "Domain %u died -- no domain info" id;
|
||||
dead_dom := id :: !dead_dom;
|
||||
) doms.table;
|
||||
List.iter (fun id ->
|
||||
|
||||
+162
-139
@@ -17,21 +17,122 @@
|
||||
open Stdext
|
||||
open Printf
|
||||
|
||||
let error fmt = Logs.error "general" fmt
|
||||
let info fmt = Logs.info "general" fmt
|
||||
let debug fmt = Logs.debug "general" fmt
|
||||
|
||||
let access_log_file = ref "/var/log/xenstored-access.log"
|
||||
let access_log_nb_files = ref 20
|
||||
let access_log_nb_lines = ref 13215
|
||||
let activate_access_log = ref true
|
||||
(* Logger common *)
|
||||
|
||||
(* maximal size of the lines in xenstore-acces.log file *)
|
||||
let line_size = 180
|
||||
type logger =
|
||||
{ stop: unit -> unit;
|
||||
restart: unit -> unit;
|
||||
rotate: unit -> unit;
|
||||
write: 'a. ('a, unit, string, unit) format4 -> 'a }
|
||||
|
||||
let log_read_ops = ref false
|
||||
let log_transaction_ops = ref false
|
||||
let log_special_ops = ref false
|
||||
let truncate_line nb_chars line =
|
||||
if String.length line > nb_chars - 1 then
|
||||
let len = max (nb_chars - 1) 2 in
|
||||
let dst_line = String.create len in
|
||||
String.blit line 0 dst_line 0 (len - 2);
|
||||
dst_line.[len-2] <- '.';
|
||||
dst_line.[len-1] <- '.';
|
||||
dst_line
|
||||
else line
|
||||
|
||||
let log_rotate ref_ch log_file log_nb_files =
|
||||
let file n = sprintf "%s.%i" log_file n in
|
||||
let log_files =
|
||||
let rec aux accu n =
|
||||
if n >= log_nb_files then accu
|
||||
else
|
||||
if n = 1 && Sys.file_exists log_file
|
||||
then aux [log_file,1] 2
|
||||
else
|
||||
let file = file (n-1) in
|
||||
if Sys.file_exists file then
|
||||
aux ((file, n) :: accu) (n+1)
|
||||
else accu in
|
||||
aux [] 1 in
|
||||
List.iter (fun (f, n) -> Unix.rename f (file n)) log_files;
|
||||
close_out !ref_ch;
|
||||
ref_ch := open_out log_file
|
||||
|
||||
let make_logger log_file log_nb_files log_nb_lines log_nb_chars post_rotate =
|
||||
let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in
|
||||
let counter = ref 0 in
|
||||
let stop() =
|
||||
try flush !channel; close_out !channel
|
||||
with _ -> () in
|
||||
let restart() =
|
||||
stop();
|
||||
channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in
|
||||
let rotate() =
|
||||
log_rotate channel log_file log_nb_files;
|
||||
(post_rotate (): unit);
|
||||
counter := 0 in
|
||||
let output s =
|
||||
let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in
|
||||
let s = s ^ "\n" in
|
||||
output_string !channel s;
|
||||
flush !channel;
|
||||
incr counter;
|
||||
if !counter > log_nb_lines then rotate() in
|
||||
{ stop=stop; restart=restart; rotate=rotate; write = fun fmt -> Printf.ksprintf output fmt }
|
||||
|
||||
|
||||
(* Xenstored logger *)
|
||||
|
||||
exception Unknown_level of string
|
||||
|
||||
type level = Debug | Info | Warn | Error | Null
|
||||
|
||||
let int_of_level = function
|
||||
| Debug -> 0 | Info -> 1 | Warn -> 2
|
||||
| Error -> 3 | Null -> max_int
|
||||
|
||||
let string_of_level = function
|
||||
| Debug -> "debug" | Info -> "info" | Warn -> "warn"
|
||||
| Error -> "error" | Null -> "null"
|
||||
|
||||
let level_of_string = function
|
||||
| "debug" -> Debug | "info" -> Info | "warn" -> Warn
|
||||
| "error" -> Error | "null" -> Null | s -> raise (Unknown_level s)
|
||||
|
||||
let string_of_date () =
|
||||
let time = Unix.gettimeofday () in
|
||||
let tm = Unix.gmtime time in
|
||||
let msec = time -. (floor time) in
|
||||
sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ"
|
||||
(1900 + tm.Unix.tm_year) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
|
||||
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
|
||||
(int_of_float (1000.0 *. msec))
|
||||
|
||||
let xenstored_log_file = ref "/var/log/xenstored.log"
|
||||
let xenstored_log_level = ref Null
|
||||
let xenstored_log_nb_files = ref 10
|
||||
let xenstored_log_nb_lines = ref 13215
|
||||
let xenstored_log_nb_chars = ref (-1)
|
||||
let xenstored_logger = ref (None: logger option)
|
||||
|
||||
let init_xenstored_log () =
|
||||
if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then
|
||||
let logger =
|
||||
make_logger
|
||||
!xenstored_log_file !xenstored_log_nb_files !xenstored_log_nb_lines
|
||||
!xenstored_log_nb_chars ignore in
|
||||
xenstored_logger := Some logger
|
||||
|
||||
let xenstored_logging level key (fmt: (_,_,_,_) format4) =
|
||||
match !xenstored_logger with
|
||||
| Some logger when int_of_level level >= int_of_level !xenstored_log_level ->
|
||||
let date = string_of_date() in
|
||||
let level = string_of_level level in
|
||||
logger.write ("[%s|%5s|%s] " ^^ fmt) date level key
|
||||
| _ -> Printf.ksprintf ignore fmt
|
||||
|
||||
let debug key = xenstored_logging Debug key
|
||||
let info key = xenstored_logging Info key
|
||||
let warn key = xenstored_logging Warn key
|
||||
let error key = xenstored_logging Error key
|
||||
|
||||
(* Access logger *)
|
||||
|
||||
type access_type =
|
||||
| Coalesce
|
||||
@@ -41,38 +142,10 @@ type access_type =
|
||||
| Endconn
|
||||
| XbOp of Xenbus.Xb.Op.operation
|
||||
|
||||
type access =
|
||||
{
|
||||
fd: out_channel ref;
|
||||
counter: int ref;
|
||||
write: tid:int -> con:string -> ?data:string -> access_type -> unit;
|
||||
}
|
||||
|
||||
let string_of_date () =
|
||||
let time = Unix.gettimeofday () in
|
||||
let tm = Unix.localtime time in
|
||||
let msec = time -. (floor time) in
|
||||
sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d" (1900 + tm.Unix.tm_year)
|
||||
(tm.Unix.tm_mon + 1)
|
||||
tm.Unix.tm_mday
|
||||
tm.Unix.tm_hour
|
||||
tm.Unix.tm_min
|
||||
tm.Unix.tm_sec
|
||||
(int_of_float (1000.0 *. msec))
|
||||
|
||||
let fill_with_space n s =
|
||||
if String.length s < n
|
||||
then
|
||||
let r = String.make n ' ' in
|
||||
String.blit s 0 r 0 (String.length s);
|
||||
r
|
||||
else
|
||||
s
|
||||
|
||||
let string_of_tid ~con tid =
|
||||
if tid = 0
|
||||
then fill_with_space 12 (sprintf "%s" con)
|
||||
else fill_with_space 12 (sprintf "%s.%i" con tid)
|
||||
then sprintf "%-12s" con
|
||||
else sprintf "%-12s" (sprintf "%s.%i" con tid)
|
||||
|
||||
let string_of_access_type = function
|
||||
| Coalesce -> "coalesce "
|
||||
@@ -109,41 +182,9 @@ let string_of_access_type = function
|
||||
|
||||
| Xenbus.Xb.Op.Error -> "error "
|
||||
| Xenbus.Xb.Op.Watchevent -> "w event "
|
||||
|
||||
(*
|
||||
| x -> Xenbus.Xb.Op.to_string x
|
||||
|
||||
let file_exists file =
|
||||
try
|
||||
Unix.close (Unix.openfile file [Unix.O_RDONLY] 0o644);
|
||||
true
|
||||
with _ ->
|
||||
false
|
||||
|
||||
let log_rotate fd =
|
||||
let file n = sprintf "%s.%i" !access_log_file n in
|
||||
let log_files =
|
||||
let rec aux accu n =
|
||||
if n >= !access_log_nb_files
|
||||
then accu
|
||||
else if n = 1 && file_exists !access_log_file
|
||||
then aux [!access_log_file,1] 2
|
||||
else
|
||||
let file = file (n-1) in
|
||||
if file_exists file
|
||||
then aux ((file,n) :: accu) (n+1)
|
||||
else accu
|
||||
in
|
||||
aux [] 1
|
||||
in
|
||||
let rec rename = function
|
||||
| (f,n) :: t when n < !access_log_nb_files ->
|
||||
Unix.rename f (file n);
|
||||
rename t
|
||||
| _ -> ()
|
||||
in
|
||||
rename log_files;
|
||||
close_out !fd;
|
||||
fd := open_out !access_log_file
|
||||
*)
|
||||
|
||||
let sanitize_data data =
|
||||
let data = String.copy data in
|
||||
@@ -154,86 +195,68 @@ let sanitize_data data =
|
||||
done;
|
||||
String.escaped data
|
||||
|
||||
let make save_to_disk =
|
||||
let fd = ref (open_out_gen [Open_append; Open_creat] 0o644 !access_log_file) in
|
||||
let counter = ref 0 in
|
||||
{
|
||||
fd = fd;
|
||||
counter = counter;
|
||||
write =
|
||||
if not !activate_access_log || !access_log_nb_files = 0
|
||||
then begin fun ~tid ~con ?data _ -> () end
|
||||
else fun ~tid ~con ?(data="") access_type ->
|
||||
let s = Printf.sprintf "[%s] %s %s %s\n" (string_of_date()) (string_of_tid ~con tid)
|
||||
(string_of_access_type access_type) (sanitize_data data) in
|
||||
let s =
|
||||
if String.length s > line_size
|
||||
then begin
|
||||
let s = String.sub s 0 line_size in
|
||||
s.[line_size-3] <- '.';
|
||||
s.[line_size-2] <- '.';
|
||||
s.[line_size-1] <- '\n';
|
||||
s
|
||||
end else
|
||||
s
|
||||
in
|
||||
incr counter;
|
||||
output_string !fd s;
|
||||
flush !fd;
|
||||
if !counter > !access_log_nb_lines
|
||||
then begin
|
||||
log_rotate fd;
|
||||
save_to_disk ();
|
||||
counter := 0;
|
||||
end
|
||||
}
|
||||
let activate_access_log = ref true
|
||||
let access_log_file = ref "/var/log/xenstored-access.log"
|
||||
let access_log_nb_files = ref 20
|
||||
let access_log_nb_lines = ref 13215
|
||||
let access_log_nb_chars = ref 180
|
||||
let access_log_read_ops = ref false
|
||||
let access_log_transaction_ops = ref false
|
||||
let access_log_special_ops = ref false
|
||||
let access_logger = ref None
|
||||
|
||||
let access : (access option) ref = ref None
|
||||
let init aal save_to_disk =
|
||||
activate_access_log := aal;
|
||||
access := Some (make save_to_disk)
|
||||
|
||||
let write_access_log ~con ~tid ?data access_type =
|
||||
let init_access_log post_rotate =
|
||||
if !access_log_nb_files > 0 then
|
||||
let logger =
|
||||
make_logger
|
||||
!access_log_file !access_log_nb_files !access_log_nb_lines
|
||||
!access_log_nb_chars post_rotate in
|
||||
access_logger := Some logger
|
||||
|
||||
let access_logging ~con ~tid ?(data="") access_type =
|
||||
try
|
||||
maybe (fun a -> a.write access_type ~con ~tid ?data) !access
|
||||
maybe
|
||||
(fun logger ->
|
||||
let date = string_of_date() in
|
||||
let tid = string_of_tid ~con tid in
|
||||
let access_type = string_of_access_type access_type in
|
||||
let data = sanitize_data data in
|
||||
logger.write "[%s] %s %s %s" date tid access_type data)
|
||||
!access_logger
|
||||
with _ -> ()
|
||||
|
||||
let new_connection = write_access_log Newconn
|
||||
let end_connection = write_access_log Endconn
|
||||
let new_connection = access_logging Newconn
|
||||
let end_connection = access_logging Endconn
|
||||
let read_coalesce ~tid ~con data =
|
||||
if !log_read_ops
|
||||
then write_access_log Coalesce ~tid ~con ~data:("read "^data)
|
||||
let write_coalesce data = write_access_log Coalesce ~data:("write "^data)
|
||||
let conflict = write_access_log Conflict
|
||||
let commit = write_access_log Commit
|
||||
if !access_log_read_ops
|
||||
then access_logging Coalesce ~tid ~con ~data:("read "^data)
|
||||
let write_coalesce data = access_logging Coalesce ~data:("write "^data)
|
||||
let conflict = access_logging Conflict
|
||||
let commit = access_logging Commit
|
||||
|
||||
let xb_op ~tid ~con ~ty data =
|
||||
let print =
|
||||
match ty with
|
||||
| Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !log_read_ops
|
||||
let print = match ty with
|
||||
| Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops
|
||||
| Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end ->
|
||||
false (* transactions are managed below *)
|
||||
| Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume ->
|
||||
!log_special_ops
|
||||
| _ -> true
|
||||
in
|
||||
if print
|
||||
then write_access_log ~tid ~con ~data (XbOp ty)
|
||||
!access_log_special_ops
|
||||
| _ -> true in
|
||||
if print then access_logging ~tid ~con ~data (XbOp ty)
|
||||
|
||||
let start_transaction ~tid ~con =
|
||||
if !log_transaction_ops && tid <> 0
|
||||
then write_access_log ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start)
|
||||
if !access_log_transaction_ops && tid <> 0
|
||||
then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start)
|
||||
|
||||
let end_transaction ~tid ~con =
|
||||
if !log_transaction_ops && tid <> 0
|
||||
then write_access_log ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end)
|
||||
if !access_log_transaction_ops && tid <> 0
|
||||
then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end)
|
||||
|
||||
let xb_answer ~tid ~con ~ty data =
|
||||
let print = match ty with
|
||||
| Xenbus.Xb.Op.Error when data="ENOENT " -> !log_read_ops
|
||||
| Xenbus.Xb.Op.Error -> !log_special_ops
|
||||
| Xenbus.Xb.Op.Error when String.startswith "ENOENT " data -> !access_log_read_ops
|
||||
| Xenbus.Xb.Op.Error -> true
|
||||
| Xenbus.Xb.Op.Watchevent -> true
|
||||
| _ -> false
|
||||
in
|
||||
if print
|
||||
then write_access_log ~tid ~con ~data (XbOp ty)
|
||||
if print then access_logging ~tid ~con ~data (XbOp ty)
|
||||
@@ -15,6 +15,8 @@
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
let info fmt = Logging.info "perms" fmt
|
||||
|
||||
open Stdext
|
||||
|
||||
let activate = ref true
|
||||
@@ -145,16 +147,16 @@ let check (connection:Connection.t) request (node:Node.t) =
|
||||
in
|
||||
match perm, request with
|
||||
| NONE, _ ->
|
||||
Logs.info "io" "Permission denied: Domain %d has no permission" domainid;
|
||||
info "Permission denied: Domain %d has no permission" domainid;
|
||||
false
|
||||
| RDWR, _ -> true
|
||||
| READ, READ -> true
|
||||
| WRITE, WRITE -> true
|
||||
| READ, _ ->
|
||||
Logs.info "io" "Permission denied: Domain %d has read only access" domainid;
|
||||
info "Permission denied: Domain %d has read only access" domainid;
|
||||
false
|
||||
| WRITE, _ ->
|
||||
Logs.info "io" "Permission denied: Domain %d has write only access" domainid;
|
||||
info "Permission denied: Domain %d has write only access" domainid;
|
||||
false
|
||||
in
|
||||
if !activate
|
||||
|
||||
@@ -14,6 +14,9 @@
|
||||
* GNU Lesser General Public License for more details.
|
||||
*)
|
||||
|
||||
let error fmt = Logging.error "process" fmt
|
||||
let info fmt = Logging.info "process" fmt
|
||||
|
||||
open Printf
|
||||
open Stdext
|
||||
|
||||
@@ -79,7 +82,7 @@ let create_implicit_path t perm path =
|
||||
|
||||
(* packets *)
|
||||
let do_debug con t domains cons data =
|
||||
if not !allow_debug
|
||||
if not (Connection.is_dom0 con) && not !allow_debug
|
||||
then None
|
||||
else try match split None '\000' data with
|
||||
| "print" :: msg :: _ ->
|
||||
@@ -89,6 +92,9 @@ let do_debug con t domains cons data =
|
||||
let domid = int_of_string domid in
|
||||
let quota = (Store.get_quota t.Transaction.store) in
|
||||
Some (Quota.to_string quota domid ^ "\000")
|
||||
| "watches" :: _ ->
|
||||
let watches = Connections.debug cons in
|
||||
Some (watches ^ "\000")
|
||||
| "mfn" :: domid :: _ ->
|
||||
let domid = int_of_string domid in
|
||||
let con = Connections.find_domain cons domid in
|
||||
@@ -357,8 +363,7 @@ let process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data =
|
||||
in
|
||||
input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data;
|
||||
with exn ->
|
||||
Logs.error "general" "process packet: %s"
|
||||
(Printexc.to_string exn);
|
||||
error "process packet: %s" (Printexc.to_string exn);
|
||||
Connection.send_error con tid rid "EIO"
|
||||
|
||||
let write_access_log ~ty ~tid ~con ~data =
|
||||
@@ -372,7 +377,7 @@ let do_input store cons doms con =
|
||||
let packet = Connection.pop_in con in
|
||||
let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in
|
||||
(* As we don't log IO, do not call an unnecessary sanitize_data
|
||||
Logs.info "io" "[%s] -> [%d] %s \"%s\""
|
||||
info "[%s] -> [%d] %s \"%s\""
|
||||
(Connection.get_domstr con) tid
|
||||
(Xenbus.Xb.Op.to_string ty) (sanitize_data data); *)
|
||||
process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data;
|
||||
@@ -386,7 +391,7 @@ let do_output store cons doms con =
|
||||
let packet = Connection.peek_output con in
|
||||
let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in
|
||||
(* As we don't log IO, do not call an unnecessary sanitize_data
|
||||
Logs.info "io" "[%s] <- %s \"%s\""
|
||||
info "[%s] <- %s \"%s\""
|
||||
(Connection.get_domstr con)
|
||||
(Xenbus.Xb.Op.to_string ty) (sanitize_data data);*)
|
||||
write_answer_log ~ty ~tid ~con ~data;
|
||||
|
||||
@@ -18,7 +18,7 @@ exception Limit_reached
|
||||
exception Data_too_big
|
||||
exception Transaction_opened
|
||||
|
||||
let warn fmt = Logs.warn "general" fmt
|
||||
let warn fmt = Logging.warn "quota" fmt
|
||||
let activate = ref true
|
||||
let maxent = ref (10000)
|
||||
let maxsize = ref (4096)
|
||||
|
||||
@@ -83,7 +83,7 @@ let check_perm node connection request =
|
||||
let check_owner node connection =
|
||||
if not (Perms.check_owner connection node.perms)
|
||||
then begin
|
||||
Logs.info "io" "Permission denied: Domain %d not owner" (get_owner node);
|
||||
Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node);
|
||||
raise Define.Permission_denied;
|
||||
end
|
||||
|
||||
|
||||
@@ -22,9 +22,14 @@ quota-transaction = 10
|
||||
# Activate filed base backend
|
||||
persistant = false
|
||||
|
||||
# Logs
|
||||
log = error;general;file:/var/log/xenstored.log
|
||||
log = warn;general;file:/var/log/xenstored.log
|
||||
log = info;general;file:/var/log/xenstored.log
|
||||
# Xenstored logs
|
||||
# xenstored-log-file = /var/log/xenstored.log
|
||||
# xenstored-log-level = null
|
||||
# xenstored-log-nb-files = 10
|
||||
|
||||
# Xenstored access logs
|
||||
# access-log-file = /var/log/xenstored-access.log
|
||||
# access-log-nb-lines = 13215
|
||||
# acesss-log-nb-chars = 180
|
||||
# access-log-special-ops = false
|
||||
|
||||
# log = debug;io;file:/var/log/xenstored-io.log
|
||||
@@ -18,7 +18,10 @@
|
||||
open Printf
|
||||
open Parse_arg
|
||||
open Stdext
|
||||
open Logging
|
||||
|
||||
let error fmt = Logging.error "xenstored" fmt
|
||||
let debug fmt = Logging.debug "xenstored" fmt
|
||||
let info fmt = Logging.info "xenstored" fmt
|
||||
|
||||
(*------------ event klass processors --------------*)
|
||||
let process_connection_fds store cons domains rset wset =
|
||||
@@ -64,7 +67,8 @@ let sigusr1_handler store =
|
||||
()
|
||||
|
||||
let sighup_handler _ =
|
||||
try Logs.reopen (); info "Log re-opened" with _ -> ()
|
||||
maybe (fun logger -> logger.Logging.restart()) !Logging.xenstored_logger;
|
||||
maybe (fun logger -> logger.Logging.restart()) !Logging.access_logger
|
||||
|
||||
let config_filename cf =
|
||||
match cf.config_file with
|
||||
@@ -75,26 +79,6 @@ let default_pidfile = "/var/run/xenstored.pid"
|
||||
|
||||
let parse_config filename =
|
||||
let pidfile = ref default_pidfile in
|
||||
let set_log s =
|
||||
let ls = String.split ~limit:3 ';' s in
|
||||
let level, key, logger = match ls with
|
||||
| [ level; key; logger ] -> level, key, logger
|
||||
| _ -> failwith "format mismatch: expecting 3 arguments" in
|
||||
|
||||
let loglevel = match level with
|
||||
| "debug" -> Log.Debug
|
||||
| "info" -> Log.Info
|
||||
| "warn" -> Log.Warn
|
||||
| "error" -> Log.Error
|
||||
| s -> failwith (sprintf "Unknown log level: %s" s) in
|
||||
|
||||
(* if key is empty, append to the default logger *)
|
||||
let append =
|
||||
if key = "" then
|
||||
Logs.append_default
|
||||
else
|
||||
Logs.append key in
|
||||
append loglevel logger in
|
||||
let options = [
|
||||
("merge-activate", Config.Set_bool Transaction.do_coalesce);
|
||||
("perms-activate", Config.Set_bool Perms.activate);
|
||||
@@ -104,14 +88,20 @@ let parse_config filename =
|
||||
("quota-maxentity", Config.Set_int Quota.maxent);
|
||||
("quota-maxsize", Config.Set_int Quota.maxsize);
|
||||
("test-eagain", Config.Set_bool Transaction.test_eagain);
|
||||
("log", Config.String set_log);
|
||||
("persistant", Config.Set_bool Disk.enable);
|
||||
("xenstored-log-file", Config.Set_string Logging.xenstored_log_file);
|
||||
("xenstored-log-level", Config.String
|
||||
(fun s -> Logging.xenstored_log_level := Logging.level_of_string s));
|
||||
("xenstored-log-nb-files", Config.Set_int Logging.xenstored_log_nb_files);
|
||||
("xenstored-log-nb-lines", Config.Set_int Logging.xenstored_log_nb_lines);
|
||||
("xenstored-log-nb-chars", Config.Set_int Logging.xenstored_log_nb_chars);
|
||||
("access-log-file", Config.Set_string Logging.access_log_file);
|
||||
("access-log-nb-files", Config.Set_int Logging.access_log_nb_files);
|
||||
("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines);
|
||||
("access-log-read-ops", Config.Set_bool Logging.log_read_ops);
|
||||
("access-log-transactions-ops", Config.Set_bool Logging.log_transaction_ops);
|
||||
("access-log-special-ops", Config.Set_bool Logging.log_special_ops);
|
||||
("access-log-nb-chars", Config.Set_int Logging.access_log_nb_chars);
|
||||
("access-log-read-ops", Config.Set_bool Logging.access_log_read_ops);
|
||||
("access-log-transactions-ops", Config.Set_bool Logging.access_log_transaction_ops);
|
||||
("access-log-special-ops", Config.Set_bool Logging.access_log_special_ops);
|
||||
("allow-debug", Config.Set_bool Process.allow_debug);
|
||||
("pid-file", Config.Set_string pidfile); ] in
|
||||
begin try Config.read filename options (fun _ _ -> raise Not_found)
|
||||
@@ -223,9 +213,6 @@ let to_file store cons file =
|
||||
end
|
||||
|
||||
let _ =
|
||||
printf "Xen Storage Daemon, version %d.%d\n%!"
|
||||
Define.xenstored_major Define.xenstored_minor;
|
||||
|
||||
let cf = do_argv in
|
||||
let pidfile =
|
||||
if Sys.file_exists (config_filename cf) then
|
||||
@@ -249,13 +236,13 @@ let _ =
|
||||
in
|
||||
|
||||
if cf.daemonize then
|
||||
Unixext.daemonize ();
|
||||
Unixext.daemonize ()
|
||||
else
|
||||
printf "Xen Storage Daemon, version %d.%d\n%!"
|
||||
Define.xenstored_major Define.xenstored_minor;
|
||||
|
||||
(try Unixext.pidfile_write pidfile with _ -> ());
|
||||
|
||||
info "Xen Storage Daemon, version %d.%d"
|
||||
Define.xenstored_major Define.xenstored_minor;
|
||||
|
||||
(* for compatilibity with old xenstored *)
|
||||
begin match cf.pidfile with
|
||||
| Some pidfile -> Unixext.pidfile_write pidfile
|
||||
@@ -293,7 +280,14 @@ let _ =
|
||||
Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun i -> sigusr1_handler store));
|
||||
Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
|
||||
|
||||
Logging.init cf.activate_access_log (fun () -> DB.to_file store cons "/var/run/xenstored/db");
|
||||
Logging.init_xenstored_log();
|
||||
if cf.activate_access_log then begin
|
||||
let post_rotate () = DB.to_file store cons "/var/run/xenstored/db" in
|
||||
Logging.init_access_log post_rotate
|
||||
end;
|
||||
|
||||
info "Xen Storage Daemon, version %d.%d"
|
||||
Define.xenstored_major Define.xenstored_minor;
|
||||
|
||||
let spec_fds =
|
||||
(match rw_sock with None -> [] | Some x -> [ x ]) @
|
||||
|
||||