Unlike -debug, -debug-on-fail will only output debug information and connection
diagnosis when the exit code is not 0.
Signed-off-by: Zheng Li <dev@xxxxxxxx>
ocaml/xe-cli/newcli.ml | 474
+++++++++++++++++++++++++++++-----------------------
1 files changed, 266 insertions(+), 208 deletions(-)
diff -r ede6c001c56e -r eaa56c96bcbf ocaml/xe-cli/newcli.ml
--- a/ocaml/xe-cli/newcli.ml Tue Mar 23 00:50:49 2010 +0000
+++ b/ocaml/xe-cli/newcli.ml Wed Mar 31 10:30:27 2010 +0100
@@ -28,16 +28,22 @@
let xapicompathost = ref "127.0.0.1"
let usessl = ref true
+let stunnel_process = ref None
let xapiport = ref None
let get_xapiport ssl =
match !xapiport with
None -> if ssl then 443 else 80
| Some p -> p
-let debug_enabled = ref false
+let debug_channel = ref None
+let debug_file = ref None
let error fmt = Printf.fprintf stderr fmt
-let debug fmt = Printf.kprintf (fun s -> if !debug_enabled then output_string
stderr s) fmt
+let debug fmt =
+ let printer s = match !debug_channel with
+ | Some c -> output_string c s
+ | None -> () in
+ Printf.kprintf printer fmt
(* usage message *)
exception Usage
@@ -91,7 +97,9 @@
if String.startswith "https://"; url
then
let stripped = end_of_string url (String.length "https://";) in
- let (host::rest) = String.split '/' stripped in
+ let host, rest =
+ let l = String.split '/' stripped in
+ List.hd l, List.tl l in
(host,"/" ^ (String.concat "/" rest))
else
(!xapiserver,url)
@@ -199,9 +207,10 @@
debug "Connecting via stunnel to [%s] port [%d]\n%!" server port;
(* We don't bother closing fds since this requires our close_and_exec
wrapper *)
let x = Stunnel.connect ~use_external_fd_wrapper:false
- ~write_to_log:(fun x -> debug "stunnel: %s\n%!" x) server port in
+ ~write_to_log:(fun x -> debug "stunnel: %s\n%!" x)
+ ~extended_diagnosis:(!debug_file <> None) server port in
+ stunnel_process := Some x;
Unix.in_channel_of_descr x.Stunnel.fd, Unix.out_channel_of_descr x.Stunnel.fd
- (* leak the stunnel process: ok because we're short-lived *)
let open_tcp server =
if !usessl && not(is_localhost server) then (* never use SSL on-host *)
@@ -230,6 +239,8 @@
exception Connect_failure
exception Protocol_version_mismatch of string
exception ClientSideError of string
+exception Stunnel_exit of int * Unix.process_status
+exception Unexpected_msg of message
let attr = ref None
@@ -238,7 +249,7 @@
(* Save the terminal state to restore it at exit *)
(attr := try Some (Unix.tcgetattr Unix.stdin) with _ -> None);
at_exit (fun () ->
- match !attr with Some a -> Unix.tcsetattr Unix.stdin Unix.TCSANOW a | None
-> ());
+ match !attr with Some a -> Unix.tcsetattr Unix.stdin Unix.TCSANOW
a | None -> ());
(* Intially exchange version information *)
let major', minor' = try unmarshal_protocol ifd with End_of_file -> raise
Connect_failure in
(* Be very conservative for the time-being *)
@@ -248,219 +259,266 @@
then raise (Protocol_version_mismatch msg);
marshal_protocol ofd;
- try
- while true do
- let cmd = unmarshal ifd in
- debug "Read: %s\n%!" (string_of_message cmd); flush stderr;
- match cmd with
- | Command (Print x) -> print_endline x; flush stdout
- | Command (PrintStderr x) -> Printf.fprintf stderr "%s\n%!" x
- | Command (Debug x) -> debug "debug from server: %s\n%!" x
- | Command (Load x) ->
- begin
- try
- let fd = Unix.openfile x [ Unix.O_RDONLY ] 0 in
- marshal ofd (Response OK);
- let length = (Unix.stat x).Unix.st_size in
- marshal ofd (Blob (Chunk (Int32.of_int length)));
- let buffer = String.make (1024 * 1024 * 10) '\000' in
- let left = ref length in
- while !left > 0 do
- let n = Unix.read fd buffer 0 (min (String.length buffer)
!left) in
- really_write ofd buffer 0 n;
- left := !left - n
- done;
- marshal ofd (Blob End);
- Unix.close fd
- with
- | e -> marshal ofd (Response Failed)
- end
- | Command (HttpPut(filename, url)) ->
- begin
- try
- let rec doit url =
- let (server,path) = parse_url url in
- if not (Sys.file_exists filename) then
- raise (ClientSideError (Printf.sprintf "file '%s' does
not exist" filename));
- let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0 in
- let stat = Unix.LargeFile.fstat fd in
- let ic, oc = open_tcp server in
- debug "PUTting to path [%s]\n%!" path;
- Printf.fprintf oc "PUT %s HTTP/1.0\r\ncontent-length:
%Ld\r\n\r\n" path stat.Unix.LargeFile.st_size;
- flush oc;
- let resultline = input_line ic in
- let headers = read_rest_of_headers ic in
- (* Get the result header immediately *)
- match http_response_code resultline with
- | 200 ->
- let fd' = Unix.descr_of_out_channel oc in
- let bytes = Unixext.copy_file fd fd' in
- debug "Written %s bytes\n%!" (Int64.to_string bytes);
- Unix.close fd;
- Unix.shutdown fd' Unix.SHUTDOWN_SEND;
- marshal ofd (Response OK)
- | 302 ->
- let newloc = List.assoc "location" headers in
- doit newloc
- | _ -> failwith "Unhandled response code"
- in
- doit url
- with
- | ClientSideError msg ->
- marshal ofd (Response Failed);
- Printf.fprintf stderr "Operation failed. Error: %s\n" msg;
- exit 1
- | e ->
- debug "HttpPut failure: %s\n%!" (Printexc.to_string e);
- (* Assume the server will figure out what's wrong and tell us
over
- the normal communication channel *)
- marshal ofd (Response Failed)
- end
- | Command (HttpGet(filename, url)) ->
- begin
- try
- let rec doit url =
- let (server,path) = parse_url url in
- debug "Opening connection to server '%s' path '%s'\n%!" server
path;
- let ic, oc = open_tcp server in
- Printf.fprintf oc "GET %s HTTP/1.0\r\n\r\n" path;
- flush oc;
- (* Get the result header immediately *)
- let resultline = input_line ic in
- debug "Got %s\n%!" resultline;
- match http_response_code resultline with
- | 200 ->
- (* Copy from channel to the file descriptor *)
- let finished = ref false in
- while not(!finished) do
- finished := input_line ic = "\r";
- done;
- let buffer = String.make 65536 '\000' in
- let finished = ref false in
- let fd =
- try
- if filename = "" then
- Unix.dup Unix.stdout
- else
- Unix.openfile filename [ Unix.O_WRONLY;
Unix.O_CREAT; Unix.O_EXCL ] 0o600
- with
- Unix.Unix_error (a,b,c) ->
- (* Note that this will close the connection to the
export handler, causing the task to fail *)
- raise (ClientSideError (Printf.sprintf "%s: %s,
%s." (Unix.error_message a) b c))
- in
- while not(!finished) do
- let num = input ic buffer 0 (String.length buffer) in
- begin try
- really_write fd buffer 0 num;
- with
- Unix.Unix_error (a,b,c) ->
- raise (ClientSideError (Printf.sprintf "%s: %s,
%s." (Unix.error_message a) b c))
- end;
- finished := num = 0;
- done;
- Unix.close fd;
- (try close_in ic with _ -> ()); (* Nb.
Unix.close_connection only requires the in_channel *)
- marshal ofd (Response OK)
- | 302 ->
- let headers = read_rest_of_headers ic in
- let newloc = List.assoc "location" headers in
- (try close_in ic with _ -> ()); (* Nb.
Unix.close_connection only requires the in_channel *)
- doit newloc
- | _ -> failwith "Unhandled response code"
- in
- doit url
- with
- | ClientSideError msg ->
- marshal ofd (Response Failed);
- Printf.fprintf stderr "Operation failed. Error: %s\n" msg;
- exit 1
- | e ->
- debug "HttpGet failure: %s\n%!" (Printexc.to_string e);
- marshal ofd (Response Failed)
- end
- | Command Prompt ->
- let data = input_line stdin in
- marshal ofd (Blob (Chunk (Int32.of_int (String.length data))));
- Unix.write ofd data 0 (String.length data);
- marshal ofd (Blob End)
- | Command (Error(code, params)) ->
- error "Error code: %s\n" code;
- error "Error parameters: %s\n" (String.concat ", " params)
- | Command (Exit x) -> exit x
- | x ->
- debug "CLI protocol failure; received non-command: %s\n%!"
(string_of_message x);
- exit 1
- done
- with e ->
- debug "CLI protocol failure; caught exception: %s\n%!" (Printexc.to_string
e);
- raise e
-
+ let exit_code = ref None in
+ while !exit_code = None do
+ while (match Unix.select [ofd] [] [] 5.0 with
+ | _ :: _, _, _ -> false
+ | _ ->
+ match !stunnel_process with
+ | Some { Stunnel.pid = Stunnel.FEFork pid } -> begin
+ match Forkhelpers.waitpid_nohang pid with
+ | 0, _ -> true
+ | i, e -> raise (Stunnel_exit (i, e))
+ end
+ | Some {Stunnel.pid = Stunnel.StdFork pid} -> begin
+ match Unix.waitpid [Unix.WNOHANG] pid with
+ | 0, _ -> true
+ | i, e -> raise (Stunnel_exit (i, e))
+ end
+ | _ -> true) do ()
+ done;
+ let cmd = unmarshal ifd in
+ debug "Read: %s\n%!" (string_of_message cmd); flush stderr;
+ match cmd with
+ | Command (Print x) -> print_endline x; flush stdout
+ | Command (PrintStderr x) -> Printf.fprintf stderr "%s\n%!" x
+ | Command (Debug x) -> debug "debug from server: %s\n%!" x
+ | Command (Load x) ->
+ begin
+ try
+ let fd = Unix.openfile x [ Unix.O_RDONLY ] 0 in
+ marshal ofd (Response OK);
+ let length = (Unix.stat x).Unix.st_size in
+ marshal ofd (Blob (Chunk (Int32.of_int length)));
+ let buffer = String.make (1024 * 1024 * 10) '\000' in
+ let left = ref length in
+ while !left > 0 do
+ let n = Unix.read fd buffer 0 (min (String.length
buffer) !left) in
+ really_write ofd buffer 0 n;
+ left := !left - n
+ done;
+ marshal ofd (Blob End);
+ Unix.close fd
+ with
+ | e -> marshal ofd (Response Failed)
+ end
+ | Command (HttpPut(filename, url)) ->
+ begin
+ try
+ let rec doit url =
+ let (server,path) = parse_url url in
+ if not (Sys.file_exists filename) then
+ raise (ClientSideError (Printf.sprintf "file
'%s' does not exist" filename));
+ let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0 in
+ let stat = Unix.LargeFile.fstat fd in
+ let ic, oc = open_tcp server in
+ debug "PUTting to path [%s]\n%!" path;
+ Printf.fprintf oc "PUT %s HTTP/1.0\r\ncontent-length:
%Ld\r\n\r\n" path stat.Unix.LargeFile.st_size;
+ flush oc;
+ let resultline = input_line ic in
+ let headers = read_rest_of_headers ic in
+ (* Get the result header immediately *)
+ match http_response_code resultline with
+ | 200 ->
+ let fd' = Unix.descr_of_out_channel oc in
+ let bytes = Unixext.copy_file fd fd' in
+ debug "Written %s bytes\n%!"
(Int64.to_string bytes);
+ Unix.close fd;
+ Unix.shutdown fd' Unix.SHUTDOWN_SEND;
+ marshal ofd (Response OK)
+ | 302 ->
+ let newloc = List.assoc "location" headers in
+ doit newloc
+ | _ -> failwith "Unhandled response code"
+ in
+ doit url
+ with
+ | ClientSideError msg ->
+ marshal ofd (Response Failed);
+ Printf.fprintf stderr "Operation failed. Error: %s\n"
msg;
+ exit 1
+ | e ->
( ...... 240 lines left ...... )
xen-api.patch
Description: Text Data
_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api
|
Home