forked from xapi-project/xen-api
-
Notifications
You must be signed in to change notification settings - Fork 0
/
apiperf.ml
169 lines (143 loc) · 6.2 KB
/
apiperf.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
(*
* 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.
*)
(* Test the performance of the XMLRPC message forwarding *)
open Threadext
open Listext
open Stringext
open Pervasiveext
open Client
let time f =
let start = Unix.gettimeofday () in
f ();
Unix.gettimeofday () -. start
let use_stunnel_cache = ref false
let master = ref false
let slave_limit = ref 0
let threads = ref 1
let url = ref ("file://" ^ "/var/lib/xcp" ^ "xapi")
type url =
| Http of string * int
| Https of string * int
| Uds of string
let url_of_string x =
let host_and_port_of_string default_port x =
match String.split ':' x with
| [ host; port ] -> host, int_of_string port
| [ host ] -> host, default_port in
match String.explode x with
| 'h' :: 't' :: 't' :: 'p' :: 's' :: ':' :: '/' :: '/' :: rest ->
let host, port = host_and_port_of_string 443 (String.implode rest) in
Https(host, port)
| 'h' :: 't' :: 't' :: 'p' :: ':' :: '/' :: '/' :: rest ->
let host, port = host_and_port_of_string 80 (String.implode rest) in
Http(host, port)
| 'f' :: 'i' :: 'l' :: 'e' :: ':' :: '/' :: '/' :: rest ->
Uds(String.implode rest)
| _ -> failwith (Printf.sprintf "Unknown URL: %s; was expecting https:// http:// or file://" x)
let string_of_url = function
| Https(host, port) -> Printf.sprintf "https://%s:%d/" host port
| Http(host, port) -> Printf.sprintf "http://%s:%d/" host port
| Uds path -> Printf.sprintf "file://%s" path
let rpc_of_url =
let open Xmlrpcclient in
let http = xmlrpc ~version:"1.0" "/" in
function
| Http(host, port) -> fun xml ->
XML_protocol.rpc ~transport:(TCP(host, port)) ~http xml
| Https(host, port) -> fun xml ->
XML_protocol.rpc ~transport:(SSL(SSL.make ~use_stunnel_cache:!use_stunnel_cache (), host, port)) ~http xml
| Uds filename -> fun xml ->
XML_protocol.rpc ~transport:(Unix filename) ~http xml
open API
open XMLRPC
let server_failure code args = raise (Api_errors.Server_error (code, args))
let rpc_wrapper rpc name args =
match From.methodResponse(rpc(To.methodCall name args)) with
| Fault _ -> invalid_arg "Client.rpc (Fault _)"
| Success [] -> XMLRPC.To.structure [] (* dummy value *)
| Success [x] -> x
| Success _ -> invalid_arg "more than one result from an RPC"
| Failure(code, strings) -> server_failure code strings
let get_log ~rpc ~session_id ~host =
let session_id = API.To.ref_session session_id in
let host = API.To.ref_host host in
API.From.string "return value of host.get_log" (rpc_wrapper rpc "host.get_log'" [ session_id; host ])
(* Use the Host.query_data_source API to test the speed of the forwarding engine *)
let test rpc session hosts nthreads time_limit =
let test_started = Unix.gettimeofday () in
let n = ref 0 in
let sigma_x = ref 0. in
let m = Mutex.create () in
let samples xs =
Mutex.execute m
(fun () ->
n := !n + (List.length xs);
sigma_x := List.fold_left (+.) !sigma_x xs
) in
let body () =
while Unix.gettimeofday () -. test_started < time_limit do
let one host = time
(fun () ->
try
if !master then begin
(* Use the invalid XMLRPC request *)
try
ignore(get_log rpc session host)
with Api_errors.Server_error(code, params) when code = Api_errors.message_method_unknown -> ()
end else begin
(* Use the valid XMLRPC request so it is forwarded *)
try
ignore(Client.Host.get_log rpc session host)
with Api_errors.Server_error(code, params) when code = Api_errors.not_implemented -> ()
end
with e ->
Printf.fprintf stderr "%s\n" (Printexc.to_string e);
flush stderr;
raise e
) in
let times = List.map one hosts in
samples times
done in
let threads = List.map (fun _ -> Thread.create body ()) (Range.to_list (Range.make 0 nthreads)) in
List.iter Thread.join threads;
let avg = !sigma_x /. (float_of_int !n) in
let ms = avg *. 1000.0 in
Printf.fprintf stderr "Total time: %.2f for %d; Average: %.1fms\n" (!sigma_x) (!n) ms;
Printf.fprintf stdout "%.1f\n" ms
let time = ref 30.
let _ =
Arg.parse [ "-master", (Arg.Set master), (Printf.sprintf "test the master only [default:%b]" !master);
"-slaves", (Arg.Set_int slave_limit), (Printf.sprintf "number of slaves to forward requests to (round-robin) [default:%d]" !slave_limit);
"-threads", (Arg.Set_int threads), (Printf.sprintf "number of parallel threads to run [default:%d]" !threads);
"-time", (Arg.Set_float time), (Printf.sprintf "set test time in seconds [default:%.2f]" !time);
"-cache", (Arg.Set use_stunnel_cache), (Printf.sprintf "use the stunnel client cache [default:%b]" !use_stunnel_cache);
"-url", (Arg.Set_string url), (Printf.sprintf "specify the URL to use [default:%s]" !url);
]
(fun x -> Printf.fprintf stderr "Skipping unknown argument: %s\n" x)
"Test the performance of the XMLRPC request forwarding engine";
let url = url_of_string !url in
let rpc = rpc_of_url url in
Printf.fprintf stderr "Using URL: %s\n" (string_of_url url);
if not !master && !slave_limit = 0 then failwith "Must provide either -master or -slaves argument";
let session = Client.Session.login_with_password rpc "root" "xenroot" "1.2" "perftest" in
finally
(fun () ->
let hosts = Client.Host.get_all rpc session in
let pool = List.hd (Client.Pool.get_all rpc session) in
let master_host = Client.Pool.get_master rpc session pool in
let slave_hosts = List.filter (fun h -> h <> master_host) hosts in
let hosts_to_test = if !master then [ master_host ] else (fst (List.chop !slave_limit slave_hosts)) in
test rpc session hosts_to_test !threads !time
)
(fun () -> Client.Session.logout rpc session)