Add support for transporting backtraces

The xapi-storage/python/xapi.py library pickles up the python backtrace
using json, this code parses it and converts it to the s-expression used
internally by xapi.

Signed-off-by: David Scott <dave.scott@eu.citrix.com>

Author: David Scott

_oasis

@@ -13,4 +13,4 @@ Executable xapi_script_storage
   MainIs:             main.ml
   Custom:             true
   Install:            false
-  BuildDepends:       xcp, xcp.storage, async_inotify, threads, message_switch.async, rpclib, xapi-storage
+  BuildDepends:       xcp, xcp.storage, async_inotify, threads, message_switch.async, rpclib, xapi-storage, sexplib, sexplib.syntax, rpclib, rpclib.syntax

main.ml

@@ -13,17 +13,20 @@
  *)
 module U = Unix
 module R = Rpc
+module B = Backtrace
 
 open Core.Std
 open Async.Std
 
+open Types
+
 let use_syslog = ref false
 
 let info fmt =
   Printf.ksprintf (fun s ->
     if !use_syslog then begin
       (* FIXME: this is synchronous and will block other I/O *)
-      Core.Syslog.syslog ~level:Core.Syslog.Level.INFO ~add_stderr:true s;
+      Core.Syslog.syslog ~level:Core.Syslog.Level.INFO s;
       return ()
     end else begin
       let w = Lazy.force Writer.stderr in
@@ -38,6 +41,20 @@ let backend_error name args =
   let exnty = Exception.Backend_error (name, args) in
   Exception.rpc_of_exnty exnty
 
+let backend_backtrace_error name args error =
+  match List.zip error.files error.lines with
+  | None -> backend_error "SCRIPT_FAILED" [ "malformed backtrace in error output" ]
+  | Some pairs ->
+    let backtrace =
+      pairs
+      |> List.map ~f:(fun (filename, line) -> { B.Interop.filename; line })
+      |> B.Interop.to_backtrace
+      |> B.sexp_of_t
+      |> Sexplib.Sexp.to_string in
+    let open Storage_interface in
+    let exnty = Exception.Backend_error_with_backtrace(name, backtrace :: args) in
+    Exception.rpc_of_exnty exnty
+
 let missing_uri () =
   backend_error "MISSING_URI" [ "Please include a URI in the device-config" ]
 
@@ -70,7 +87,16 @@ let fork_exec_rpc root_dir script_name args response_of_rpc =
     >>= fun output ->
     begin match output.Process.Output.exit_status with
     | Error (`Exit_non_zero code) ->
-      return (Error (backend_error "SCRIPT_FAILED" [ script_name; "non-zero exit"; string_of_int code; output.Process.Output.stdout; output.Process.Output.stderr ]))
+      (* Expect an exception and backtrace on stderr *)
+      begin match Or_error.try_with (fun () -> Jsonrpc.of_string output.Process.Output.stderr) with
+      | Error _ ->
+        return (Error (backend_error "SCRIPT_FAILED" [ script_name; "non-zero exit and bad json on stderr"; string_of_int code; output.Process.Output.stdout; output.Process.Output.stderr ]))
+      | Ok response ->
+        begin match Or_error.try_with (fun () -> error_of_rpc response) with
+        | Error _ -> return (Error (backend_error "SCRIPT_FAILED" [ script_name; "non-zero exit and bad json on stderr"; string_of_int code; output.Process.Output.stdout; output.Process.Output.stderr ]))
+        | Ok x -> return (Error(backend_backtrace_error "SCRIPT_FAILED" [ script_name; "non-zero exit"; string_of_int code; output.Process.Output.stdout ] x))
+        end
+      end
     | Error (`Signal signal) ->
       return (Error (backend_error "SCRIPT_FAILED" [ script_name; "signalled"; Signal.to_string signal; output.Process.Output.stdout; output.Process.Output.stderr ]))
     | Ok () ->

types.ml

@@ -0,0 +1,22 @@
+(*
+ * Copyright (C) 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 Sexplib.Std
+
+(* This matches xapi.py:exception *)
+type error = {
+  error: string;
+  (* Python json.dumps and rpclib are not very friendly *)
+  files: string list;
+  lines: int list;
+} with rpc