From 11de7f259cde45571800062d02881febe2440608 Mon Sep 17 00:00:00 2001 From: David Scott Date: Mon, 26 Oct 2009 16:32:15 +0000 Subject: [PATCH] [refactoring] move debug.ml from xen-api.hg to xen-api-libs.hg/log Signed-off-by: Thomas Gazagnaire --- log/META.in | 1 + log/Makefile | 27 ++++------ log/debug.ml | 132 +++++++++++++++++++++++++++++++++++++++++++++++++ log/debug.mli | 58 ++++++++++++++++++++++ log/log.ml | 20 ++++++-- log/log.mli | 100 ++++++++++++++++++++++++++----------- log/logs.ml | 2 +- log/logs.mli | 43 ++++++++++++++++ log/syslog.mli | 41 +++++++++++++++ 9 files changed, 375 insertions(+), 49 deletions(-) create mode 100644 log/debug.ml create mode 100644 log/debug.mli create mode 100644 log/logs.mli create mode 100644 log/syslog.mli diff --git a/log/META.in b/log/META.in index 5c3646a..98f0c4c 100644 --- a/log/META.in +++ b/log/META.in @@ -1,4 +1,5 @@ version = "@VERSION@" description = "Log - logging library" +requires = "unix,stdext" archive(byte) = "log.cma" archive(native) = "log.cmxa" diff --git a/log/Makefile b/log/Makefile index be0719a..28d9fb6 100644 --- a/log/Makefile +++ b/log/Makefile @@ -15,8 +15,8 @@ OCAMLABI := $(shell ocamlc -version) OCAMLLIBDIR := $(shell ocamlc -where) OCAMLDESTDIR ?= $(OCAMLLIBDIR) -OBJS = syslog log logs -INTF = log.cmi logs.cmi syslog.cmi +OBJS = syslog log logs debug +INTF = log.cmi logs.cmi syslog.cmi debug.cmi LIBS = log.cma log.cmxa all: $(INTF) $(LIBS) $(PROGRAMS) @@ -38,32 +38,25 @@ libsyslog_stubs.a: syslog_stubs.o ar rcs $@ $+ ocamlmklib -o syslog_stubs $+ -%.cmo: %.ml - $(OCAMLC) -c $(OCAMLCFLAGS) -o $@ $< - %.cmi: %.mli $(OCAMLC) -c $(OCAMLCFLAGS) -o $@ $< -%.cmx: %.ml - $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $< +%.cmo: %.ml %.cmi + $(OCAMLC) -c $(OCAMLCFLAGS) -thread -o $@ $< + +%.cmx: %.ml %.cmi + $(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $< %.o: %.c $(CC) $(CFLAGS) -c -o $@ $< -logs.mli : logs.ml - $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@ - -syslog.mli : syslog.ml - $(OCAMLC) -i $< > $@ - META: META.in sed 's/@VERSION@/$(VERSION)/g' < $< > $@ #dependency: -log.cmo: syslog.cmo log.cmi -log.cmx: syslog.cmx log.cmi -logs.cmo: log.cmi -logs.cmx: log.cmx +log.cmi: syslog.cmi +logs.cmi: log.cmi +debug.cmi: logs.cmi .PHONY: install install: $(LIBS) META diff --git a/log/debug.ml b/log/debug.ml new file mode 100644 index 0000000..bdd43e8 --- /dev/null +++ b/log/debug.ml @@ -0,0 +1,132 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * 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 Stringext +open Pervasiveext +open Threadext + +(** Associate a task with each active thread *) +let thread_tasks : (int, string) Hashtbl.t = Hashtbl.create 256 +let thread_tasks_m = Mutex.create () + +let get_thread_id () = + try Thread.id (Thread.self ()) with _ -> -1 + +(* Theses functions need to be defined later in the code. *) +let get_hostname = + let f () = "Debug.get_hostname not set" in + ref f + +let associate_thread_with_task task = + let id = get_thread_id () in + if id <> -1 + then begin + Mutex.execute thread_tasks_m (fun () -> Hashtbl.add thread_tasks id task); + end + +let get_task_from_thread () = + let id = get_thread_id () in + Mutex.execute thread_tasks_m + (fun () -> if Hashtbl.mem thread_tasks id then Some(Hashtbl.find thread_tasks id) else None) + +let dissociate_thread_from_task () = + let id = get_thread_id () in + if id <> -1 + then match get_task_from_thread () with + | Some _ -> + Mutex.execute thread_tasks_m (fun () -> Hashtbl.remove thread_tasks id) + | None -> + let extra = Printf.sprintf "[thread: debug (%n)] " id in + Logs.info ~extra "debug" "Thread id %d is not associated with any task" id + +let with_thread_associated task f x = + associate_thread_with_task task; + finally + (fun () -> f x) + dissociate_thread_from_task + +let threadnames = Hashtbl.create 256 +let tnmutex = Mutex.create () +module StringSet = Set.Make(struct type t=string let compare=Pervasives.compare end) +let debug_keys = ref StringSet.empty +let get_all_debug_keys () = + StringSet.fold (fun key keys -> key::keys) !debug_keys [] + +let dkmutex = Mutex.create () + +let _ = Hashtbl.add threadnames (-1) "no thread" + +let get_thread_id () = + try Thread.id (Thread.self ()) with _ -> -1 + +let name_thread name = + let id = get_thread_id () in + Mutex.execute tnmutex (fun () -> Hashtbl.add threadnames id name) + +let remove_thread_name () = + let id = get_thread_id () in + Mutex.execute tnmutex (fun () -> Hashtbl.remove threadnames id) + +module type BRAND = sig + val name: string +end + +module Debugger = functor(Brand: BRAND) -> struct + let hostname = Unix.gethostname () + let _ = + Mutex.execute dkmutex (fun () -> + debug_keys := StringSet.add Brand.name !debug_keys) + + let get_thread_name () = + let id = get_thread_id () in + Mutex.execute tnmutex + (fun () -> + try + Printf.sprintf "%d %s" id (Hashtbl.find threadnames id) + with _ -> + Printf.sprintf "%d" id) + + let get_task () = + default "" (may (fun s -> s) (get_task_from_thread ())) + + let output (f:string -> ?extra:string -> ('a, unit, string, 'b) format4 -> 'a) fmt = + let extra = + Printf.sprintf "%s|%s|%s|%s" + hostname + (get_thread_name ()) + (get_task ()) + Brand.name + in + f Brand.name ~extra fmt + + let output_and_return ?raw (f:string -> ?raw:bool -> ?extra:string -> ('a, unit, string, 'b) format4 -> 'a) fmt = + let extra = + Printf.sprintf "%s|%s|%s|%s" + hostname + (get_thread_name ()) + (get_task ()) + Brand.name + in + f Brand.name ?raw ~extra fmt + + let debug fmt = output Logs.debug fmt + let warn fmt = output Logs.warn fmt + let info fmt = output Logs.info fmt + let error fmt = output Logs.error fmt + let audit ?raw fmt = output_and_return ?raw Logs.audit fmt + + let log_backtrace () = + let backtrace = Backtrace.get_backtrace () in + debug "%s" (String.escaped backtrace) + +end diff --git a/log/debug.mli b/log/debug.mli new file mode 100644 index 0000000..22e0013 --- /dev/null +++ b/log/debug.mli @@ -0,0 +1,58 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * 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. + *) + +(** Debug utilities *) + +(** {2 Associate a task to the current actions} *) + +(** Associate a task name to the current thread *) +val associate_thread_with_task : string -> unit + +(** Dissociate a task name to the current thread *) +val dissociate_thread_from_task : unit -> unit + +(** Do an action with a task name associated with the current thread *) +val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b + +(** {2 Associate a name to the current thread} *) + +val name_thread : string -> unit + +val remove_thread_name : unit -> unit + +val get_all_debug_keys : unit -> string list + +module type BRAND = sig val name : string end + +module Debugger : functor (Brand : BRAND) -> +sig + + (** Debug function *) + val debug : ('a, unit, string, unit) format4 -> 'a + + (** Warn function *) + val warn : ('a, unit, string, unit) format4 -> 'a + + (** Info function *) + val info : ('a, unit, string, unit) format4 -> 'a + + (** Error function *) + val error : ('a, unit, string, unit) format4 -> 'a + + (** Audit function *) + val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a + + val log_backtrace : unit -> unit +end + diff --git a/log/log.ml b/log/log.ml index ad7e10c..3d3b0e4 100644 --- a/log/log.ml +++ b/log/log.ml @@ -13,7 +13,15 @@ *) open Printf -open Threadext + +module Mutex = struct + include Mutex + let execute lock f = + Mutex.lock lock; + let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in + Mutex.unlock lock; + r +end exception Unknown_level of string @@ -64,6 +72,12 @@ let mkdir_rec dir perm = type t = { output: output; mutable level: level; } +let get_strings t = match t.output with + | String s -> !s + | _ -> [] + +let get_level t = t.level + let make output level = { output = output; level = level; } let make_stream ty channel = @@ -134,7 +148,7 @@ let close t = | String _ -> () (** create a string representating the parameters of the logger *) -let string_of_logger t = +let to_string t = match t.output with | Nil -> "nil" | Syslog k -> sprintf "syslog:%s" k @@ -148,7 +162,7 @@ let string_of_logger t = end (** parse a string to a logger *) -let logger_of_string s : t = +let of_string s : t = match s with | "nil" -> opennil () | "stderr" -> openerr Debug diff --git a/log/log.mli b/log/log.mli index 607b7b5..3eb1a1c 100644 --- a/log/log.mli +++ b/log/log.mli @@ -11,46 +11,90 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -exception Unknown_level of string + +(** Logging utilities *) + +type t + +(** create a string representating the parameters of the logger *) +val to_string : t -> string + +(** parse a string to a logger *) +val of_string : string -> t + +(** try to reopen a logger *) +val reopen : t -> t + +(** close a logger *) +val close : t -> unit + +val gettimestring : unit -> string + +(** {2 Builders} *) + type level = Debug | Info | Warn | Error +val get_level : t -> level -type stream_type = Stderr | Stdout | File of string -type stream_log = { - ty : stream_type; - channel : out_channel option ref; - mutex : Mutex.t; -} -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 +exception Unknown_level of 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 string_of_level : level -> string + +(** open a syslog logger *) val opensyslog : string -> level -> t + +(** open a stderr logger *) val openerr : level -> t + +(** open a stdout logger *) val openout : level -> t + +(** open a stream logger - returning the output type *) val openfile : string -> level -> t + +(** open a nil logger *) val opennil : unit -> t + +(** open a string logger *) 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 filesize : int ref -val mutex : Mutex.t +val get_strings : t -> string list + +(** {2 Raw output functions} *) + val output : t -> ?key:string -> ?extra:string -> level -> string -> unit val output_and_return : t -> ?raw:bool -> ?key:string -> ?extra:string -> level -> string -> string -val log : t -> level -> ('a, unit, string, unit) format4 -> 'a + +(** {2 Pretty output functions} *) + 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 +val log : t -> level -> ('a, unit, string, unit) format4 -> 'a + +(** {2 Output validation} *) + +val validate : string -> unit + +(** {2 Concurrency} *) + +(** TODO: It would be very nice to have a thread-free log module (ie. put the control outside that module). + This mutex protects all the recorded outputs. *) +val mutex : Mutex.t + +(** TODO: remove the global state (what happens if multiple log files are opened???) ! *) +val filesize : int ref + +(* +type stream_type = Stderr | Stdout | File of string +type stream_log = { + ty : stream_type; + channel : out_channel option ref; + mutex : Mutex.t; +} + +val int_of_level : level -> int +val mkdir_safe : string -> Unix.file_perm -> unit +val mkdir_rec : string -> Unix.file_perm -> unit +val set : t -> level -> unit +val mutex : Mutex.t +*) diff --git a/log/logs.ml b/log/logs.ml index 94a8a38..8adac3d 100644 --- a/log/logs.ml +++ b/log/logs.ml @@ -41,7 +41,7 @@ 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 + let t = Log.of_string logstring in Hashtbl.add __all_loggers logstring t; t diff --git a/log/logs.mli b/log/logs.mli new file mode 100644 index 0000000..0aa701e --- /dev/null +++ b/log/logs.mli @@ -0,0 +1,43 @@ +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_common : + string -> + Log.level -> + ?extra:string -> + ret_fn1:(string -> 'a) -> + ret_fn2:(Log.t list -> 'b) -> ('b, unit, string, 'a) format4 -> 'b +val log : + string -> + Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +val log_and_return : + string -> + Log.level -> + ?raw:bool -> ?extra:string -> ('a, unit, string, string) 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 +val audit : + string -> + ?raw:bool -> ?extra:string -> ('a, unit, string, string) format4 -> 'a diff --git a/log/syslog.mli b/log/syslog.mli new file mode 100644 index 0000000..eabafb8 --- /dev/null +++ b/log/syslog.mli @@ -0,0 +1,41 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * 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 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" + + -- 2.39.5