# HG changeset patch # User Zheng Li # Date 1272950528 -3600 # Node ID ad5ea8e64ad268ea8a99ca1bda96a962a04e348a # Parent abc48d958c408ffa2f9aa72addeb4ca8507a5096 A few bugfixes and a few minor improvements to current xe cmdline tool implementation Bugfixes: * xe command line options doesn't mix well with XE_EXTRA_ARGS varialbe. E.g. setting XE_EXTRA_ARGS to "username=xxxx,password=yyyy" (or any non-nil valid configuration) and calling "xe -s vm-list" will break xe. Note that this is a common user case in a cluster-like environment where all the machines have the same user/passwd config, where one can conveniently set user/passwd in XE_EXTRA_ARGS for once and connect to different servers by only specifying different "-s" arguments in the cmdline. * Setting "compat=true" in xe's RC file won't work. E.g. xe vm-clone vm-name= new-name= with "compat=true" in ~/.xe won't work (but with "compat=true" in XE_EXTRA_ARGS or in xe cmdline will work). * Setting a password with comma via XE_EXTRA_ARGS will break the logic. After the fix, it's possible to specify that by using backslash to escape the comma (e.g. password=pass\,word) * clean up the options handling logic, so that cmdline options, RC file setting and XE_EXTRA_ARGS variable can mix consistently even in some corner cases and follow the natural priority: cmdline option > XE_EXTRA_ARGS > ~/.xe RC > default settings Improvements: * change options "-debug" and "-debug-on-fail" to "--debug" and "--debug-on-fail", so that every command line option now follows the common naming convention of -shortcut v.s.--full-name (with the only standard exception of having both "-help" and "--help"). AFAICS, both debug options are (maybe deliberately) not documented in the manual, so changing the names might not be a big issue regarding compatibilities. * complete the pair relation between command line options and RC/environment variables. There were some missings from either side: e.g. "compat=xxxx" has no "--compat" correspondence and "--debug"("--debug-on-fail") has not "debug=xxxx" in par. Signed-off-by: Zheng Li diff -r abc48d958c40 -r ad5ea8e64ad2 ocaml/xe-cli/newcli.ml --- a/ocaml/xe-cli/newcli.ml Fri Apr 23 19:30:04 2010 +0100 +++ b/ocaml/xe-cli/newcli.ml Tue May 04 06:22:08 2010 +0100 @@ -15,33 +15,34 @@ open Stringext open Cli_protocol -(* Need to know about the host and port to know who to connect to *) -(* Strictly, we don't need to know the username and password, but I want to be able *) -(* to make a .xe file containing defaults, so we'll pull them out of Sys.argv anyway *) +(* Param config priorities: + explicit cmd option > XE_XXX env variable > ~/.xe rc file > default +*) -(* cmdline options override .xe options override these *) let xapiserver = ref "127.0.0.1" let xapiuname = ref "root" let xapipword = ref "null" let xapicompatmode = ref false let xapipasswordfile = ref "" let xapicompathost = ref "127.0.0.1" - -let usessl = ref true -let stunnel_process = ref None -let xapiport = ref None +let xapiport = ref None let get_xapiport ssl = match !xapiport with - None -> if ssl then 443 else 80 - | Some p -> p + None -> if ssl then 443 else 80 + | Some p -> p +let xeusessl = ref true +let xedebug = ref false +let xedebugonfail = ref false + +let stunnel_process = ref None let debug_channel = ref None let debug_file = ref None let error fmt = Printf.fprintf stderr fmt -let debug fmt = - let printer s = match !debug_channel with - | Some c -> output_string c s +let debug fmt = + let printer s = match !debug_channel with + | Some c -> output_string c s | None -> () in Printf.kprintf printer fmt @@ -49,12 +50,12 @@ exception Usage let usage () = - if !xapicompatmode + if !xapicompatmode then begin error "COMPATABILITY MODE\n"; error "Usage: %s [-h server] [-p port] ([-u username] [-pw password] or [-pwf ]) \n" Sys.argv.(0); - error "\nA full list of commands can be obtained by running \n\t%s help -s -p \n" Sys.argv.(0) + error "\nA full list of commands can be obtained by running \n\t%s help -h -p \n" Sys.argv.(0) end else begin @@ -68,36 +69,36 @@ exception Http_parse_failure let hdrs = ["content-length"; "cookie"; "connection"; "transfer-encoding"; "authorization"; "location"] - + let end_of_string s from = String.sub s from ((String.length s)-from) - + let strip_cr r = if String.length r=0 then raise Http_parse_failure; let last_char = String.sub r ((String.length r)-1) 1 in if last_char <> "\r" then raise Http_parse_failure; String.sub r 0 ((String.length r)-1) - + let rec read_rest_of_headers ic = try let r = input_line ic in let r = strip_cr r in if r="" then [] else begin - debug "read '%s'\n" r; - let hdr = List.find (fun s -> String.startswith (s^": ") (String.lowercase r)) hdrs in - let value = end_of_string r (String.length hdr + 2) in - (hdr,value)::read_rest_of_headers ic + debug "read '%s'\n" r; + let hdr = List.find (fun s -> String.startswith (s^": ") (String.lowercase r)) hdrs in + let value = end_of_string r (String.length hdr + 2) in + (hdr,value)::read_rest_of_headers ic end with - | Not_found -> read_rest_of_headers ic - | _ -> [] - + | Not_found -> read_rest_of_headers ic + | _ -> [] + let parse_url url = if String.startswith "https://" url then let stripped = end_of_string url (String.length "https://") in - let host, rest = + let host, rest = let l = String.split '/' stripped in List.hd l, List.tl l in (host,"/" ^ (String.concat "/" rest)) @@ -120,7 +121,7 @@ exit 1 -let parse_port (x: string) = +let parse_port (x: string) = try let p = int_of_string x in if p < 0 || p > 65535 then failwith "illegal"; @@ -131,104 +132,135 @@ (* Extract the arguments we're interested in. Return a list of the argumets we know *) (* nothing about. These will get passed straight into the server *) -let parse_args args = - +let parse_args = + (* Set the key to the value. Return whether the key is one we know about *) (* compat mode is special as the argument is passed in two places. Once *) - (* at the top of the message to the cli server in order to indicate that *) + (* at the top of the message to the cli server in order to indicate that *) (* we need to use 'geneva style' parsing - that is, allow key = value as *) (* opposed to key=value. Secondly, the key then gets passed along with *) (* all the others to the operations. So we need to register it's there, *) (* but not strip it *) + + let reserve_args = ref [] in + let set_keyword (k,v) = - match k with - "server" -> xapiserver := v; true - | "port" -> xapiport := Some (parse_port v); true - | "username" -> xapiuname := v; true - | "password" -> xapipword := v; true - | "passwordfile" -> xapipasswordfile := v; true - | "nossl" -> usessl := not(bool_of_string v); true - | "compat" -> xapicompatmode := (try (bool_of_string v) with _ -> false); false (* dont strip it! *) - | _ -> false - in + try + (match k with + | "server" -> xapiserver := v + | "port" -> xapiport := Some (parse_port v) + | "username" -> xapiuname := v + | "password" -> xapipword := v + | "passwordfile" -> xapipasswordfile := v + | "nossl" -> xeusessl := not(bool_of_string v) + | "compat" -> + xapicompatmode := (try (bool_of_string v) with _ -> false); + reserve_args := (k ^ "=" ^ v) :: !reserve_args + | "debug" -> xedebug := (try bool_of_string v with _ -> false) + | "debugonfail" -> xedebugonfail := (try bool_of_string v with _ -> false) + | _ -> raise Not_found); + true + with Not_found -> false in - let rec doit args = + let parse_opt args = match args with - | "--help"::_ - | "-help"::_ -> - raise Usage - | "-s"::server::xs -> - xapiserver := server; - doit xs - | "-p"::port::xs -> - xapiport := Some (parse_port port); - doit xs - | "-u"::uname::xs -> - xapiuname := uname; - doit xs - | "-pw"::pw::xs -> - xapipword := pw; - doit xs - | "--nossl"::xs -> - usessl := false; - doit xs - | "-pwf"::pwf::xs -> - xapipasswordfile := pwf; - doit xs - | "-h"::h::xs -> - xapicompathost := h; - doit xs - | x::xs -> - (* we eat cmdline params if we know about them *) - let eatit = - begin - try - let eq = String.index x '=' in - let k = String.sub x 0 eq in - let v = String.sub x (eq+1) (String.length x - (eq+1)) in - set_keyword (k,v) - with _ -> false - end - in - if eatit then doit xs else x::(doit xs) - | _ -> [] - in + | "-s" :: server :: xs -> Some ("server", server, xs) + | "-p" :: port :: xs -> Some("port", port, xs) + | "-u" :: uname :: xs -> Some("username", uname, xs) + | "-pw" :: pw :: xs -> Some("password", pw, xs) + | "-pwf" :: pwf :: xs -> Some("passwordfile", pwf, xs) + | "--nossl" :: xs -> Some("nossl", "true", xs) + | "--compat" :: xs -> Some("compat", "true", xs) + | "--debug" :: xs -> Some("debug", "true", xs) + | "--debug-on-fail" :: xs -> Some("debugonfail", "true", xs) + | "-h" :: h :: xs -> Some("server", h, xs) + | _ -> None in - let defaults = Options.read_rc () in - ignore (List.map set_keyword defaults); (* Defaults from the fil ~/.xe *) - let newargs = doit args in - (if !xapipasswordfile <> "" then read_pwf ()); - (if !xapicompatmode then xapiserver := !xapicompathost); - newargs + let parse_eql arg = + try + let eq = String.index arg '=' in + let k = String.sub arg 0 eq in + let v = String.sub arg (eq+1) (String.length arg - (eq+1)) in + Some (k,v) + with _ -> None in -let open_tcp_ssl server = + let rec process_args = function + | [] -> [] + | args -> + match parse_opt args with + | Some(k, v, rest) -> + if set_keyword(k, v) then process_args rest else process_eql args + | None -> + process_eql args + and process_eql = function + | [] -> [] + | arg :: args -> + match parse_eql arg with + | Some(k, v) when set_keyword(k,v) -> process_args args + | _ -> arg :: process_args args in + + fun args -> + let rcs = Options.read_rc() in + let rcs_rest = + List.map (fun (k,v) -> k^"="^v) + (List.filter (fun (k, v) -> not (set_keyword (k,v))) rcs) in + let extras = + let extra_args = try Sys.getenv "XE_EXTRA_ARGS" with Not_found -> "" in + let l = ref [] and pos = ref 0 and i = ref 0 in + while !pos < String.length extra_args do + if extra_args.[!pos] = ',' then (incr pos; i := !pos) + else + if !i >= String.length extra_args + || extra_args.[!i] = ',' && extra_args.[!i-1] <> '\\' then + (let seg = String.sub extra_args !pos (!i - !pos) in + l := String.filter_chars seg ((<>) '\\') :: !l; + incr i; pos := !i) + else incr i + done; + List.rev !l in + let extras_rest = process_args extras in + let help = ref false in + let args' = List.filter (fun s -> s<>"-help" && s <> "--help") args in + if List.length args' < List.length args then help := true; + let args_rest = process_args args in + if !help then raise Usage; + let () = + if !xapipasswordfile <> "" then read_pwf (); + if !xedebug then debug_channel := Some stderr; + if !xedebugonfail then begin + let tmpfile, tmpch = Filename.open_temp_file "xe_debug" "tmp" in + debug_file := Some tmpfile; + debug_channel := Some tmpch + end in + args_rest @ extras_rest @ rcs_rest @ !reserve_args + +let open_tcp_ssl server = let port = get_xapiport true in 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) + let x = Stunnel.connect ~use_external_fd_wrapper:false + ~write_to_log:(fun x -> debug "stunnel: %s\n%!" x) ~extended_diagnosis:(!debug_file <> None) server port in if !stunnel_process = None then stunnel_process := Some x; Unix.in_channel_of_descr x.Stunnel.fd, Unix.out_channel_of_descr x.Stunnel.fd let open_tcp server = - if !usessl && not(is_localhost server) then (* never use SSL on-host *) - open_tcp_ssl server - else ( - let host = Unix.gethostbyname server in - let addr = host.Unix.h_addr_list.(0) in - Unix.open_connection (Unix.ADDR_INET (addr,get_xapiport false)) - ) + if !xeusessl && not(is_localhost server) then (* never use SSL on-host *) + open_tcp_ssl server + else ( + let host = Unix.gethostbyname server in + let addr = host.Unix.h_addr_list.(0) in + Unix.open_connection (Unix.ADDR_INET (addr,get_xapiport false)) + ) -let open_channels () = - if is_localhost !xapiserver then ( - try - Unix.open_connection (Unix.ADDR_UNIX "/var/xapi/xapi") - with _ -> - open_tcp !xapiserver - ) else +let open_channels () = + if is_localhost !xapiserver then ( + try + Unix.open_connection (Unix.ADDR_UNIX "/var/xapi/xapi") + with _ -> open_tcp !xapiserver - + ) else + open_tcp !xapiserver let http_response_code x = match String.split ' ' x with | [ _; code; _ ] -> int_of_string code @@ -241,20 +273,19 @@ exception Stunnel_exit of int * Unix.process_status exception Unexpected_msg of message -let attr = ref None - +let attr = ref None let main_loop ifd ofd = (* Save the terminal state to restore it at exit *) (attr := try Some (Unix.tcgetattr Unix.stdin) with _ -> None); - at_exit (fun () -> + at_exit (fun () -> 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 *) let msg = Printf.sprintf "Server has protocol version %d.%d. Client has %d.%d" major' minor' major minor in debug "%s\n%!" msg; - if major' <> major || minor' <> minor + if major' <> major || minor' <> minor then raise (Protocol_version_mismatch msg); marshal_protocol ofd; @@ -265,18 +296,18 @@ *) while (match Unix.select [ifd] [] [] 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 + 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 + end | _ -> true) do () done; let cmd = unmarshal ifd in @@ -286,135 +317,135 @@ | 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 + 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 -> + 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_code := Some 1 - | e -> - debug "HttpPut failure: %s\n%!" (Printexc.to_string e); - (* Assume the server will figure out what's wrong and tell us over + | 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 + 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 -> + 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_code := Some 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) + | 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) + error "Error code: %s\n" code; + error "Error parameters: %s\n" (String.concat ", " params) | Command (Exit c) -> exit_code := Some c | x -> @@ -428,78 +459,68 @@ 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_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 + let xe, args = + match Array.to_list Sys.argv with + | h :: t -> h, t + | _ -> assert false 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 (); exit 0) else + let args = parse_args args in + + if List.length args < 1 then raise 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 + let ic, oc = open_channels () in + Printf.fprintf oc "POST /cli HTTP/1.0\r\n"; + let args = args @ [("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 (); - Printf.fprintf oc "POST /cli HTTP/1.0\r\n"; - let args = args@[("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 + 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 -> + exit_status := 0; 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(); + 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(); + 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; + 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 + 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" + 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" + 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.\n" i - (match e with + error "Stunnel process %d %s.\n" 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 + 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 + | Some p -> + if Sys.file_exists p.Stunnel.logfile then begin if !exit_status <> 0 then (debug "\nStunnel diagnosis:\n\n";