Merge pull request #11 from djs55/experimental-backtraces

Transport backtraces through the API

Author: djs55

_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

_tags

@@ -1,8 +1,9 @@
 # OASIS_START
-# DO NOT EDIT (digest: 7c0996ac9ce2363431af4daae4cbaead)
+# DO NOT EDIT (digest: d4caced815577ed0a5b4b8487e4f2276)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
+true: annot, bin_annot
 <**/.svn>: -traverse
 <**/.svn>: not_hygienic
 ".bzr": -traverse
@@ -17,16 +18,22 @@
 <main.{native,byte}>: pkg_async_inotify
 <main.{native,byte}>: pkg_message_switch.async
 <main.{native,byte}>: pkg_rpclib
+<main.{native,byte}>: pkg_rpclib.syntax
+<main.{native,byte}>: pkg_sexplib
+<main.{native,byte}>: pkg_sexplib.syntax
 <main.{native,byte}>: pkg_threads
 <main.{native,byte}>: pkg_xapi-storage
 <main.{native,byte}>: pkg_xcp
 <main.{native,byte}>: pkg_xcp.storage
-<*.ml{,i}>: pkg_async_inotify
-<*.ml{,i}>: pkg_message_switch.async
-<*.ml{,i}>: pkg_rpclib
-<*.ml{,i}>: pkg_threads
-<*.ml{,i}>: pkg_xapi-storage
-<*.ml{,i}>: pkg_xcp
-<*.ml{,i}>: pkg_xcp.storage
+<*.ml{,i,y}>: pkg_async_inotify
+<*.ml{,i,y}>: pkg_message_switch.async
+<*.ml{,i,y}>: pkg_rpclib
+<*.ml{,i,y}>: pkg_rpclib.syntax
+<*.ml{,i,y}>: pkg_sexplib
+<*.ml{,i,y}>: pkg_sexplib.syntax
+<*.ml{,i,y}>: pkg_threads
+<*.ml{,i,y}>: pkg_xapi-storage
+<*.ml{,i,y}>: pkg_xcp
+<*.ml{,i,y}>: pkg_xcp.storage
 <main.{native,byte}>: custom
 # OASIS_STOP

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

myocamlbuild.ml

@@ -1,5 +1,5 @@
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 5a9a2168dcb86db37476d58b8c0e25b3) *)
+(* DO NOT EDIT (digest: 2b686a81cec9fb16d1640bda36a68fbd) *)
 module OASISGettext = struct
 (* # 22 "src/oasis/OASISGettext.ml" *)
 
@@ -249,6 +249,9 @@ module MyOCamlbuildFindlib = struct
     *)
   open Ocamlbuild_plugin
 
+  type conf =
+    { no_automatic_syntax: bool;
+    }
 
   (* these functions are not really officially exported *)
   let run_and_read =
@@ -315,7 +318,7 @@ module MyOCamlbuildFindlib = struct
 
   (* This lists all supported packages. *)
   let find_packages () =
-    List.map before_space (split_nl & run_and_read "ocamlfind list")
+    List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list"))
 
 
   (* Mock to list available syntaxes. *)
@@ -338,7 +341,7 @@ module MyOCamlbuildFindlib = struct
   ]
 
 
-  let dispatch =
+  let dispatch conf =
     function
       | After_options ->
           (* By using Before_options one let command line options have an higher
@@ -357,31 +360,39 @@ module MyOCamlbuildFindlib = struct
            * -linkpkg *)
           flag ["ocaml"; "link"; "program"] & A"-linkpkg";
 
-          (* For each ocamlfind package one inject the -package option when
-           * compiling, computing dependencies, generating documentation and
-           * linking. *)
-          List.iter
-            begin fun pkg ->
-              let base_args = [A"-package"; A pkg] in
-              (* TODO: consider how to really choose camlp4o or camlp4r. *)
-              let syn_args = [A"-syntax"; A "camlp4o"] in
-              let args =
-              (* Heuristic to identify syntax extensions: whether they end in
-                 ".syntax"; some might not.
-               *)
-                if Filename.check_suffix pkg "syntax" ||
-                   List.mem pkg well_known_syntax then
-                  syn_args @ base_args
-                else
-                  base_args
-              in
-              flag ["ocaml"; "compile";  "pkg_"^pkg] & S args;
-              flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
-              flag ["ocaml"; "doc";      "pkg_"^pkg] & S args;
-              flag ["ocaml"; "link";     "pkg_"^pkg] & S base_args;
-              flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
-            end
-            (find_packages ());
+          if not (conf.no_automatic_syntax) then begin
+            (* For each ocamlfind package one inject the -package option when
+             * compiling, computing dependencies, generating documentation and
+             * linking. *)
+            List.iter
+              begin fun pkg ->
+                let base_args = [A"-package"; A pkg] in
+                (* TODO: consider how to really choose camlp4o or camlp4r. *)
+                let syn_args = [A"-syntax"; A "camlp4o"] in
+                let (args, pargs) =
+                  (* Heuristic to identify syntax extensions: whether they end in
+                     ".syntax"; some might not.
+                  *)
+                  if Filename.check_suffix pkg "syntax" ||
+                     List.mem pkg well_known_syntax then
+                    (syn_args @ base_args, syn_args)
+                  else
+                    (base_args, [])
+                in
+                flag ["ocaml"; "compile";  "pkg_"^pkg] & S args;
+                flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
+                flag ["ocaml"; "doc";      "pkg_"^pkg] & S args;
+                flag ["ocaml"; "link";     "pkg_"^pkg] & S base_args;
+                flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
+
+                (* TODO: Check if this is allowed for OCaml < 3.12.1 *)
+                flag ["ocaml"; "compile";  "package("^pkg^")"] & S pargs;
+                flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs;
+                flag ["ocaml"; "doc";      "package("^pkg^")"] & S pargs;
+                flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs;
+              end
+              (find_packages ());
+          end;
 
           (* Like -package but for extensions syntax. Morover -syntax is useless
            * when linking. *)
@@ -546,12 +557,13 @@ module MyOCamlbuildBase = struct
 
                    (* When ocaml link something that use the C library, then one
                       need that file to be up to date.
+                      This holds both for programs and for libraries.
                     *)
-                   dep ["link"; "ocaml"; "program"; tag_libstubs lib]
-                     [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
+  		 dep ["link"; "ocaml"; tag_libstubs lib]
+  		     [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
 
-                   dep  ["compile"; "ocaml"; "program"; tag_libstubs lib]
-                     [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
+  		 dep  ["compile"; "ocaml"; tag_libstubs lib]
+  		      [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
 
                    (* TODO: be more specific about what depends on headers *)
                    (* Depends on .h files *)
@@ -580,25 +592,27 @@ module MyOCamlbuildBase = struct
             ()
 
 
-  let dispatch_default t =
+  let dispatch_default conf t =
     dispatch_combine
       [
         dispatch t;
-        MyOCamlbuildFindlib.dispatch;
+        MyOCamlbuildFindlib.dispatch conf;
       ]
 
 
 end
 
 
-# 594 "myocamlbuild.ml"
+# 606 "myocamlbuild.ml"
 open Ocamlbuild_plugin;;
 let package_default =
   {MyOCamlbuildBase.lib_ocaml = []; lib_c = []; flags = []; includes = []}
   ;;
 
-let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
+let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false}
+
+let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;;
 
-# 603 "myocamlbuild.ml"
+# 617 "myocamlbuild.ml"
 (* OASIS_STOP *)
 Ocamlbuild_plugin.dispatch dispatch_default;;