From: Edwin Török <edvin.torok@citrix.com>

Unhandled exceptions go to stderr by default, but this doesn't typically work
for oxenstored because:
 * daemonize reopens stderr as /dev/null
 * systemd redirects stderr to /dev/null too

Debugging an unhandled exception requires reproducing the issue locally when
using --no-fork, and is not conducive to figuring out what went wrong on a
remote system.

Install a custom handler which also tries to render the backtrace to the
configured syslog facility, and DAEMON|ERR otherwise.

Signed-off-by: Edwin Török <edvin.torok@citrix.com>
Signed-off-by: Andrew Cooper <andrew.cooper3@citrix.com>
Acked-by: Christian Lindig <christian.lindig@citrix.com>
---
CC: Christian Lindig <christian.lindig@citrix.com>
CC: David Scott <dave@recoil.org>
CC: Edwin Torok <edvin.torok@citrix.com>
CC: Rob Hoes <Rob.Hoes@citrix.com>

Drop print_flush as prerr_endline already flushes.
---
 tools/ocaml/xenstored/logging.ml   | 29 +++++++++++++++++++++++++++++
 tools/ocaml/xenstored/xenstored.ml |  3 ++-
 2 files changed, 31 insertions(+), 1 deletion(-)

diff --git a/tools/ocaml/xenstored/logging.ml b/tools/ocaml/xenstored/logging.ml
index 39c3036155a2..255051437d60 100644
--- a/tools/ocaml/xenstored/logging.ml
+++ b/tools/ocaml/xenstored/logging.ml
@@ -342,3 +342,32 @@ let xb_answer ~tid ~con ~ty data =
 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\n" (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
diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml
index 23621bd49397..257481285f05 100644
--- a/tools/ocaml/xenstored/xenstored.ml
+++ b/tools/ocaml/xenstored/xenstored.ml
@@ -357,7 +357,8 @@ let tweak_gc () =
 	Gc.set { (Gc.get ()) with Gc.max_overhead = !Define.gc_max_overhead }
 
 
-let _ =
+let () =
+	Printexc.set_uncaught_exception_handler Logging.fallback_exception_handler;
 	let cf = do_argv in
 	let pidfile =
 		if Sys.file_exists (config_filename cf) then
-- 
2.11.0