xen/tools/ocaml/xenstored/logging.ml

(*
 * Copyright (C) 2006-2007 XenSource Ltd.
 * Copyright (C) 2008      Citrix Ltd.
 * Author Thomas Gazagnaire <thomas.gazagnaire@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 Stdext
open Printf


(* Logger common *)

type log_destination =
	| File of string
	| Syslog of Syslog.facility

let log_destination_of_string s =
	let prefix = "syslog:" in
	let len_prefix = String.length prefix in
	let len = String.length s in
	if String.startswith prefix s
	then Syslog(Syslog.facility_of_string (String.sub s len_prefix (len - len_prefix)))
	else File s

(* The prefix of a log line depends on the log destination *)
let prefix log_destination ?level ?key date = match log_destination with
	| File _ ->
		let level = match level with
			| Some x -> Printf.sprintf "|%5s" x
			| None -> "" in
		let key = match key with
			| Some x -> "|" ^ x
			| None -> "" in
		Printf.sprintf "[%s%s%s] " date level key
	| Syslog _ ->
		let key = match key with
			| Some x -> "[" ^ x ^ "] "
			| None -> "" in
		(* Syslog handles the date and level internally *)
		key

type level = Debug | Info | Warn | Error | Null

type logger =
		{ stop: unit -> unit;
		  restart: unit -> unit;
		  rotate: unit -> unit;
		  write: ?level:level -> string -> unit }

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 = Bytes.create len in
		Bytes.blit_string line 0 dst_line 0 (len - 2);
		Bytes.set dst_line (len-2) '.';
		Bytes.set dst_line (len-1) '.';
		Bytes.unsafe_to_string 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_file_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 write ?level:_ 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=write }

exception Unknown_level of string

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))

(* We can defer to syslog for log management *)
let make_syslog_logger facility =
	(* When TZ is unset in the environment, each syslog call will stat the
	   /etc/localtime file at least three times during the process. We'd like to
	   avoid this cost given that we are not a mobile environment and we log
	   almost every xenstore entry update/watch. *)
	let () =
		let tz_is_set =
			try String.length (Unix.getenv "TZ") > 0
			with Not_found -> false in
		if not tz_is_set then Unix.putenv "TZ" "/etc/localtime" in
	let nothing () = () in
	let write ?level s =
		let level = match level with
			| Some Error -> Syslog.Err
			| Some Warn -> Syslog.Warning
			| Some Info -> Syslog.Info
			| Some Debug -> Syslog.Debug
			| Some Null -> Syslog.Debug
			| None -> Syslog.Debug in
		(* Syslog handles the date and level internally *)
		Syslog.log facility level s in
	{ stop = nothing; restart = nothing; rotate = nothing; write=write }

let xenstored_log_destination = ref (File (Paths.xen_log_dir ^ "/xenstored.log"))
let xenstored_log_level = ref Warn
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 debug_enabled () = !xenstored_log_level = Debug

let set_xenstored_log_destination s =
	xenstored_log_destination := log_destination_of_string s

let set_xenstored_logger logger =
	xenstored_logger := Some logger;
	logger.write ~level:Info (Printf.sprintf "Xen Storage Daemon, version %d.%d"
	Define.xenstored_major Define.xenstored_minor)


let init_xenstored_log () = match !xenstored_log_destination with
	| File file ->
		if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then
			let logger =
				make_file_logger
					file !xenstored_log_nb_files !xenstored_log_nb_lines
					!xenstored_log_nb_chars ignore in
			set_xenstored_logger logger
	| Syslog facility ->
		set_xenstored_logger (make_syslog_logger facility)


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
			let prefix = prefix !xenstored_log_destination ~level:level' ~key date in
			Printf.ksprintf (fun s -> logger.write ~level (prefix ^ s)) fmt
	| _ -> 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
	| Conflict
	| Commit
	| Newconn
	| Endconn
	| Watch_not_fired
	| XbOp of Xenbus.Xb.Op.operation

let string_of_tid ~con tid =
	if tid = 0
	then sprintf "%-12s" con
	else sprintf "%-12s" (sprintf "%s.%i" con tid)

let string_of_access_type = function
	| Coalesce                -> "coalesce "
	| Conflict                -> "conflict "
	| Commit                  -> "commit   "
	| Newconn                 -> "newconn  "
	| Endconn                 -> "endconn  "
	| Watch_not_fired         -> "w notfired"

	| XbOp op -> match op with
	| Xenbus.Xb.Op.Debug             -> "debug    "

	| Xenbus.Xb.Op.Directory         -> "directory"
	| Xenbus.Xb.Op.Read              -> "read     "
	| Xenbus.Xb.Op.Getperms          -> "getperms "

	| Xenbus.Xb.Op.Watch             -> "watch    "
	| Xenbus.Xb.Op.Unwatch           -> "unwatch  "

	| Xenbus.Xb.Op.Transaction_start -> "t start  "
	| Xenbus.Xb.Op.Transaction_end   -> "t end    "

	| Xenbus.Xb.Op.Introduce         -> "introduce"
	| Xenbus.Xb.Op.Release           -> "release  "
	| Xenbus.Xb.Op.Getdomainpath     -> "getdomain"
	| Xenbus.Xb.Op.Isintroduced      -> "is introduced"
	| Xenbus.Xb.Op.Resume            -> "resume   "

	| Xenbus.Xb.Op.Write             -> "write    "
	| Xenbus.Xb.Op.Mkdir             -> "mkdir    "
	| Xenbus.Xb.Op.Rm                -> "rm       "
	| Xenbus.Xb.Op.Setperms          -> "setperms "
	| Xenbus.Xb.Op.Reset_watches     -> "reset watches"
	| Xenbus.Xb.Op.Set_target        -> "settarget"

	| Xenbus.Xb.Op.Error             -> "error    "
	| Xenbus.Xb.Op.Watchevent        -> "w event  "
	| Xenbus.Xb.Op.Invalid           -> "invalid  "
	(*
	| x                       -> Xenbus.Xb.Op.to_string x
	*)

let sanitize_data data =
	let data = String.init
		(String.length data)
		(fun i -> let c = data.[i] in if c = '\000' then ' ' else c)
	in
	String.escaped data

let activate_access_log = ref true
let access_log_destination = ref (File (Paths.xen_log_dir ^ "/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 set_access_log_destination s =
	access_log_destination := log_destination_of_string s

let init_access_log post_rotate = match !access_log_destination with
	| File file ->
		if !access_log_nb_files > 0 then
			let logger =
				make_file_logger
					file !access_log_nb_files !access_log_nb_lines
					!access_log_nb_chars post_rotate in
			access_logger := Some logger
	| Syslog facility ->
		access_logger := Some (make_syslog_logger facility)

let access_logging ~con ~tid ?(data="") ~level access_type =
        try
		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
				let prefix = prefix !access_log_destination date in
				let msg = Printf.sprintf "%s %s %s %s" prefix tid access_type data in
				logger.write ~level msg)
			!access_logger
	with _ -> ()

let new_connection = access_logging ~level:Debug Newconn
let end_connection = access_logging ~level:Debug Endconn
let read_coalesce ~tid ~con data =
	if !access_log_read_ops
        then access_logging Coalesce ~tid ~con ~data:("read "^data) ~level:Debug
let write_coalesce data = access_logging Coalesce ~data:("write "^data) ~level:Debug
let conflict = access_logging Conflict ~level:Debug
let commit = access_logging Commit ~level:Debug

let xb_op ~tid ~con ~ty data =
	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 ->
			!access_log_special_ops
		| _ -> true in
	if print then access_logging ~tid ~con ~data (XbOp ty) ~level:Info

let start_transaction ~tid ~con =
	if !access_log_transaction_ops && tid <> 0
	then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ~level:Debug

let end_transaction ~tid ~con =
	if !access_log_transaction_ops && tid <> 0
	then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) ~level:Debug

let live_update () =
	xb_op ~tid:0 ~con:"" ~ty:Xenbus.Xb.Op.Debug "Live update begin"

let xb_answer ~tid ~con ~ty data =
	let print, level = match ty with
		| Xenbus.Xb.Op.Error when String.startswith "ENOENT" data -> !access_log_read_ops , Warn
		| Xenbus.Xb.Op.Error -> true , Warn
		| Xenbus.Xb.Op.Watchevent -> true , Info
		| _ -> false, Debug
	in
	if print then access_logging ~tid ~con ~data (XbOp ty) ~level

let watch_not_fired ~con perms path =
	let data = Printf.sprintf "EPERM perms=[%s] path=%s" perms path in
	access_logging ~tid:0 ~con ~data Watch_not_fired ~level:Info

let msg_of exn bt =
	Printf.sprintf "Fatal exception: %s\n%s" (Printexc.to_string exn)
		(Printexc.raw_backtrace_to_string bt)

let fallback_exception_handler exn bt =
	(* stderr goes to /dev/null, so use the logger where possible,
	   but always print to stderr too, in case everything else fails,
	   e.g. this can be used to debug with --no-fork

	   this function should try not to raise exceptions, but if it does
	   the ocaml runtime should still print the exception, both the original,
	   and the one from this function, but to stderr this time
	 *)
	let msg = msg_of exn bt in
	prerr_endline msg;
	(* See Printexc.set_uncaught_exception_handler, need to flush,
	   so has to call stop and flush *)
	match !xenstored_logger with
	| Some l -> error "xenstored-fallback" "%s" msg; l.stop ()
	| None ->
		(* Too early, no logger set yet.
		   We normally try to use the configured logger so we don't flood syslog
		   during development for example, or if the user has a file set
		 *)
		try Syslog.log Syslog.Daemon Syslog.Err msg
		with e ->
			let bt = Printexc.get_raw_backtrace () in
			prerr_endline @@ msg_of e bt