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 <some server> 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=<vm name> new-name=<new vm 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 <[email protected]>
ocaml/xe-cli/newcli.ml | 577
+++++++++++++++++++++++++++-------------------------
1 files changed, 299 insertions(+), 278 deletions(-)
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 <cmd> [-h server] [-p port] ([-u username] [-pw
password] or [-pwf <password file>]) <other arguments>\n" Sys.argv.(0);
- error "\nA full list of commands can be obtained by running \n\t%s help
-s <server> -p <port>\n" Sys.argv.(0)
+ error "\nA full list of commands can be obtained by running \n\t%s help
-h <server> -p <port>\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
( ...... 455 lines left ...... )
# HG changeset patch
# User Zheng Li <[email protected]>
# 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 <some server> 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=<vm name> new-name=<new vm 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 <[email protected]>
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 <cmd> [-h server] [-p port] ([-u username] [-pw password] or [-pwf <password file>]) <other arguments>\n" Sys.argv.(0);
- error "\nA full list of commands can be obtained by running \n\t%s help -s <server> -p <port>\n" Sys.argv.(0)
+ error "\nA full list of commands can be obtained by running \n\t%s help -h <server> -p <port>\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 = 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
+ 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";
_______________________________________________
xen-api mailing list
[email protected]
http://lists.xensource.com/mailman/listinfo/xen-api
