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 <[email protected]> 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 ...... )
# HG changeset patch # User Zheng Li <[email protected]> # Date 1270027827 -3600 # Node ID eaa56c96bcbfcc22c9f573acdb59471d7342aa41 # Parent ede6c001c56ea614b3f800378a6fd0d880906374 Add -debug-on-fail option to "xe" and other minor improvements 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 <[email protected]> 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 -> + 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)))); + ignore (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 c) -> + exit_code := Some c + | x -> + raise (Unexpected_msg x) + done; + match !exit_code with Some c -> c | _ -> assert false + let main () = - try + let exit_status = ref 1 in + let _ = try Sys.set_signal Sys.sigpipe Sys.Signal_ignore; Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> exit 1)); Stunnel.init_stunnel_path(); let args = Array.to_list Sys.argv in - let args = if List.mem "-debug" args - then (debug_enabled := true; List.filter (fun x -> x <> "-debug") args) + let args = + if List.mem "-debug" args + then (debug_channel := Some stderr; List.filter (fun x -> x <> "-debug") args) else args in + let args = + if List.mem "-debug-on-fail" args + then begin + let tmpfile, tmpch = Filename.open_temp_file "xe_debug_info" "tmp" in + debug_file := Some tmpfile; debug_channel := Some tmpch; + List.filter (fun x -> x <> "-debug-on-fail") args + end else args in if List.mem "-version" args then begin - Printf.printf "ThinCLI protocol: %d.%d\n" major minor; - exit 0 + Printf.printf "ThinCLI protocol: %d.%d\n" major minor; + exit 0 end; if List.length args < 2 then usage () else begin - let extra_args = try Sys.getenv "XE_EXTRA_ARGS" with _ -> "" in - let split_extra = List.filter (fun s -> String.length s > 1) (String.split ',' extra_args) in - let cmd = List.nth args 1 in - let args = parse_args (cmd :: split_extra @ (List.tl (List.tl args))) in - let ic, oc = open_channels () in - - Printf.fprintf oc "POST /cli HTTP/1.0\r\n"; - let args = a...@[("username="^ !xapiuname);("password="^ !xapipword)] in - let args = if !xapicompatmode then "compat"::args else args in - let args = String.concat "\n" args in - Printf.fprintf oc "User-agent: xe-cli/Unix/%d.%d\r\n" major minor; - Printf.fprintf oc "content-length: %d\r\n\r\n" (String.length args); - Printf.fprintf oc "%s" args; - flush_all (); - - let in_fd = Unix.descr_of_in_channel ic - and out_fd = Unix.descr_of_out_channel oc in - main_loop in_fd out_fd + let extra_args = try Sys.getenv "XE_EXTRA_ARGS" with _ -> "" in + let split_extra = List.filter (fun s -> String.length s > 1) (String.split ',' extra_args) in + let cmd = List.nth args 1 in + let args = parse_args (cmd :: split_extra @ (List.tl (List.tl args))) in + let ic, oc = open_channels () in + + Printf.fprintf oc "POST /cli HTTP/1.0\r\n"; + let args = a...@[("username="^ !xapiuname);("password="^ !xapipword)] in + let args = if !xapicompatmode then "compat"::args else args in + let args = String.concat "\n" args in + Printf.fprintf oc "User-agent: xe-cli/Unix/%d.%d\r\n" major minor; + Printf.fprintf oc "content-length: %d\r\n\r\n" (String.length args); + Printf.fprintf oc "%s" args; + flush_all (); + + let in_fd = Unix.descr_of_in_channel ic + and out_fd = Unix.descr_of_out_channel oc in + exit_status := main_loop in_fd out_fd end with - | Usage -> usage (); - | Not_a_cli_server -> - error "Failed to contact a running XenServer management agent.\n"; - error "Try specifying a server name and port.\n"; - usage(); - exit 1 - | Protocol_version_mismatch x -> - error "Protocol version mismatch: %s.\n" x; - error "Try specifying a server name and port on the command-line.\n"; - usage(); - exit 1 - | Not_found -> - error "Host '%s' not found.\n" !xapiserver; - exit 1 - | Unix.Unix_error(err,fn,arg) as e -> - error "Error: %s (calling %s %s)\n" (Unix.error_message err) fn arg; - exit 1 - | Connect_failure -> - error "Unable to contact server. Please check server and port settings.\n"; - exit 1 - | Stunnel.Stunnel_binary_missing -> - error "Please install the stunnel package or define the XE_STUNNEL environment variable to point to the binary.\n"; - exit 1 - | End_of_file -> - error "Lost connection to the server.\n"; - exit 1 - | e -> - error "Unhandled exception\n%s\n" (Printexc.to_string e); - exit 1 + | Usage -> + usage (); + | Not_a_cli_server -> + error "Failed to contact a running XenServer management agent.\n"; + error "Try specifying a server name and port.\n"; + usage(); + | Protocol_version_mismatch x -> + error "Protocol version mismatch: %s.\n" x; + error "Try specifying a server name and port on the command-line.\n"; + usage(); + | Not_found -> + error "Host '%s' not found.\n" !xapiserver; + | Unix.Unix_error(err,fn,arg) -> + error "Error: %s (calling %s %s)\n" (Unix.error_message err) fn arg + | Connect_failure -> + error "Unable to contact server. Please check server and port settings.\n" + | Stunnel.Stunnel_binary_missing -> + error "Please install the stunnel package or define the XE_STUNNEL environment variable to point to the binary.\n" + | End_of_file -> + error "Lost connection to the server.\n" + | Unexpected_msg m -> + error "Unexpected message from server: %s" (string_of_message m) + | Stunnel_exit (i, e) -> + error "Stunnel process %d %s" i + (match e with + | Unix.WEXITED c -> "existed with exit code " ^ string_of_int c + | Unix.WSIGNALED c -> "killed by signal " ^ string_of_int c + | Unix.WSTOPPED c -> "stopped by signal " ^ string_of_int c) + | e -> + error "Unhandled exception\n%s\n" (Printexc.to_string e) in + begin match !stunnel_process with + | Some p -> + if Sys.file_exists p.Stunnel.logfile then + begin + if !exit_status <> 0 then + (debug "\nStunnel diagnosis:\n\n"; + try Stunnel.diagnose_failure p + with e -> debug "%s\n" (Printexc.to_string e)); + try Unix.unlink p.Stunnel.logfile with _ -> () + end; + Stunnel.disconnect p + | None -> () + end; + begin match !debug_file, !debug_channel with + | Some f, Some ch -> begin + close_out ch; + if !exit_status <> 0 then begin + output_string stderr "\nDebug info:\n\n"; + output_string stderr (Unixext.read_whole_file_to_string f) + end; + try Unix.unlink f with _ -> () + end + | _ -> () + end; + exit !exit_status -let _ = main () - - +let _ = main ()
_______________________________________________ xen-api mailing list [email protected] http://lists.xensource.com/mailman/listinfo/xen-api
