Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 7c62863b04
Fetching contributors…

Cannot retrieve contributors at this time

680 lines (637 sloc) 25.412 kb
(*
* Copyright (C) 2006-2009 Citrix Systems Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
(* New cli talking to the in-server cli interface *)
open Stringext
open Cli_protocol
(* Param config priorities:
explicit cmd option > XE_XXX env variable > ~/.xe rc file > default
*)
let xapiserver = ref "127.0.0.1"
let xapiuname = ref "root"
let xapipword = ref "null"
let xapipasswordfile = ref ""
let xapicompathost = ref "127.0.0.1"
let xapiport = ref None
let get_xapiport ssl =
match !xapiport with
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 heartbeat_version = 0.2
let heartbeat_interval = 300.
let long_connection_retry_timeout = 5.
let error fmt = Printf.fprintf stderr 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
let usage () =
error "Usage: %s <cmd> [-s 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)
let is_localhost ip = ip = "127.0.0.1"
(* HTTP level bits and pieces *)
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
end
with
| 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 l = String.split '/' stripped in
List.hd l, List.tl l in
(host,"/" ^ (String.concat "/" rest))
else
(!xapiserver,url)
(* Read the password file *)
let read_pwf () =
try
let ic = open_in !xapipasswordfile in
try
xapiuname := (input_line ic);
xapipword := (input_line ic)
with End_of_file ->
error "Error: password file format: expecting username on the first line, password on the second line\n";
exit 1
with _ ->
error "Error opening password file '%s'\n" !xapipasswordfile;
exit 1
let parse_port (x: string) =
try
let p = int_of_string x in
if p < 0 || p > 65535 then failwith "illegal";
p
with _ ->
error "Port number must be an integer (0-65535)\n";
raise Usage
(* 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 =
(* 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 *)
(* 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) =
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)
| "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 parse_opt args =
match args with
| "-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)
| "--debug" :: xs -> Some("debug", "true", xs)
| "--debug-on-fail" :: xs -> Some("debugonfail", "true", xs)
| "-h" :: h :: xs -> Some("server", h, xs)
| _ -> None in
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 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_fork_exec_helper: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 !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 (Filename.concat Fhs.vardir "xapi"))
with _ ->
open_tcp !xapiserver
) else
open_tcp !xapiserver
let http_response_code x = match String.split ' ' x with
| _ :: code :: _ -> int_of_string code
| _ -> failwith "Bad response from HTTP server"
let copy_with_heartbeat ?(block=65536) in_ch out_ch heartbeat_fun =
let buf = String.make block '\000' in
let last_heartbeat = ref (Unix.time()) in
let finish = ref false in
while not !finish do
let bytes = input in_ch buf 0 block in
if bytes <> 0 then
output out_ch buf 0 bytes
else begin
flush out_ch;
finish := true
end;
let now = Unix.time () in
if now -. !last_heartbeat >= heartbeat_interval then begin
heartbeat_fun ();
last_heartbeat := now
end
done
exception Http_failure
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
exception Server_internal_error
let handle_unmarshal_failure ex ifd = match ex with
| Unmarshal_failure (e, s) ->
let s = s ^ Unixext.try_read_string ifd in
debug "Read: %s\n" s;
if String.length s >= 4 && String.uppercase (String.sub s 0 4) = "HTTP"
then raise Server_internal_error
else raise e
| e -> raise e
let main_loop ifd ofd =
(* Intially exchange version information *)
let major', minor' =
try unmarshal_protocol ifd with
| Unmarshal_failure (_, "") -> raise Connect_failure
| e -> handle_unmarshal_failure e ifd in
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
then raise (Protocol_version_mismatch msg);
let with_heartbeat =
major' * 10 + minor' >= int_of_float (heartbeat_version *. 10.) in
let heartbeat_fun =
if with_heartbeat then (fun () -> marshal ofd (Response Wait))
else ignore in
marshal_protocol ofd;
let exit_code = ref None in
while !exit_code = None do
(* Wait for input asynchronously so that we can check the status
of Stunnel every now and then, for better debug/dignosis.
*)
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
| 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 =
try unmarshal ifd
with e -> handle_unmarshal_failure e 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%!" 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
Unixext.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 (HttpConnect(url)) ->
let server, path = parse_url url in
(* The releatively complex design here helps to buffer input/output
when the underlying connection temporarily breaks, hence provides
seemingly continous connection. *)
let block = 65536 in
let buf_local = String.make block '\000' in
let buf_local_end = ref 0 in
let buf_local_start = ref 0 in
let buf_remote = String.make block '\000' in
let buf_remote_end = ref 0 in
let buf_remote_start = ref 0 in
let final = ref false in
let tc_save = ref None in
let connection ic oc =
let fd = Unix.descr_of_out_channel oc in
Printf.fprintf oc "CONNECT %s HTTP/1.0\r\ncontent-length: 0\r\n\r\n" path;
flush oc;
let resultline = input_line ic in
let _ = read_rest_of_headers ic in
(* Get the result header immediately *)
begin match http_response_code resultline with
| 200 ->
if !tc_save = None then begin
(* Remember the current terminal state so we can restore it *)
let tc = Unix.tcgetattr Unix.stdin in
(* Switch into a raw mode, passing through stuff like Control + C *)
let tc' = {
tc with
Unix.c_ignbrk = false;
Unix.c_brkint = false;
Unix.c_parmrk = false;
Unix.c_istrip = false;
Unix.c_inlcr = false;
Unix.c_igncr = false;
Unix.c_icrnl = false;
Unix.c_ixon = false;
Unix.c_opost = false;
Unix.c_echo = false;
Unix.c_echonl = false;
Unix.c_icanon = false;
Unix.c_isig = false;
(* IEXTEN? *)
Unix.c_csize = 8;
Unix.c_parenb = false;
Unix.c_vmin = 0;
Unix.c_vtime = 0;
} in
Unix.tcsetattr Unix.stdin Unix.TCSANOW tc';
tc_save := Some tc
end;
let finished = ref false in
let last_heartbeat = ref (Unix.time ()) in
while not !finished do
if !buf_local_start <> !buf_local_end then begin
let b = Unix.write Unix.stdout buf_local
!buf_local_start (!buf_local_end - !buf_local_start)
in
buf_local_start := !buf_local_start + b;
if !buf_local_start = !buf_local_end then
(buf_local_start := 0; buf_local_end := 0)
end
else if !buf_remote_start <> !buf_remote_end then begin
let b = Unix.write fd buf_remote !buf_remote_start
(!buf_remote_end - !buf_remote_start) in
buf_remote_start := !buf_remote_start + b;
if !buf_remote_start = !buf_remote_end then
(buf_remote_start := 0; buf_remote_end := 0)
end
else if !final then finished := true
else begin
let r, _, _ =
Unix.select [Unix.stdin; fd] [] [] heartbeat_interval in
let now = Unix.time () in
if now -. !last_heartbeat >= heartbeat_interval then begin
heartbeat_fun ();
last_heartbeat := now
end;
if List.mem Unix.stdin r then begin
let b = Unix.read Unix.stdin buf_remote
!buf_remote_end (block - !buf_remote_end) in
let i = ref !buf_remote_end in
while !i < !buf_remote_end + b && Char.code buf_remote.[!i] <> 0x1d do incr i; done;
if !i < !buf_remote_end + b then final := true;
buf_remote_end := !i
end;
if List.mem fd r then begin
let b = Unix.read fd buf_local
!buf_local_end (block - !buf_local_end) in
buf_local_end := !buf_local_end + b
end
end
done;
marshal ofd (Response OK)
| 404 ->
Printf.fprintf stderr "Server replied with HTTP 404: the console is not available\n";
marshal ofd (Response Failed)
| x ->
Printf.fprintf stderr "Server said: %s" resultline;
marshal ofd (Response Failed)
end in
let delay = ref 0.1 in
let rec keep_connection () =
try
let ic, oc = open_tcp server in
delay := 0.1;
Pervasiveext.finally
(fun () -> connection ic oc)
(fun () -> try close_in ic with _ -> ())
with
| Unix.Unix_error (_, _, _)
when !delay <= long_connection_retry_timeout ->
ignore (Unix.select [] [] [] !delay);
delay := !delay *. 2.;
keep_connection ()
| e ->
prerr_endline (Printexc.to_string e);
marshal ofd (Response Failed) in
keep_connection ();
(match !tc_save with
| Some tc ->
Unix.tcsetattr Unix.stdin Unix.TCSANOW tc;
print_endline "\r"
| None -> ())
| 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 file_ch = open_in_bin filename in
let file_size = LargeFile.in_channel_length file_ch 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 file_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 ->
Pervasiveext.finally
(fun () ->
copy_with_heartbeat file_ch oc heartbeat_fun;
marshal ofd (Response OK))
(fun () ->
(try close_in ic with _ -> ());
(try close_in file_ch with _ -> ()))
| 302 ->
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 "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 ->
let file_ch =
if filename = "" then
Unix.out_channel_of_descr (Unix.dup Unix.stdout)
else
try open_out_gen [Open_wronly; Open_creat; Open_excl] 0o600 filename
with e -> raise (ClientSideError (Printexc.to_string e))
in
while input_line ic <> "\r" do () done;
Pervasiveext.finally
(fun () ->
copy_with_heartbeat ic file_ch heartbeat_fun;
marshal ofd (Response OK))
(fun () ->
(try close_in ic with _ -> ());
(try close_out file_ch with _ -> ()))
| 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)
| 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 () =
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));
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
end;
let args = parse_args args in
if List.length args < 1 then raise Usage else
begin
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 = 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 ->
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();
| 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)
| Server_internal_error ->
error "Server internal error.\n"
| Stunnel_exit (i, e) ->
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 " ^ (Unixext.string_of_signal 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 ~wait:false ~force:true 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.string_of_file f)
end;
try Unix.unlink f with _ -> ()
end
| _ -> ()
end;
exit !exit_status
let _ = main ()
Jump to Line
Something went wrong with that request. Please try again.