2
* Copyright (C) 2006-2009 Citrix Systems Inc.
4
* This program is free software; you can redistribute it and/or modify
5
* it under the terms of the GNU Lesser General Public License as published
6
* by the Free Software Foundation; version 2.1 only. with the special
7
* exception on linking described in file LICENSE.
9
* This program is distributed in the hope that it will be useful,
10
* but WITHOUT ANY WARRANTY; without even the implied warranty of
11
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12
* GNU Lesser General Public License for more details.
20
(* === Common XML operations === *)
22
(** Generates an XML leaf element of the form: *)
23
(** <name>value</name> *)
24
let xml_leaf_element name value =
26
name, [], [Xml.PCData value]
29
(** Returns true iff. the given element matches the given name. *)
30
let xml_element_has_name name element =
32
| Xml.Element (name_, _, _) -> name = name_
35
(** Returns a sub-list of the given element list, containing *)
36
(** only those elements with the specified name. *)
37
let xml_elements_with_name elements name =
38
List.filter (xml_element_has_name name) elements
40
(** Returns the first element with the specified name from *)
41
(** the given element list. *)
42
let first_xml_element_with_name elements name =
44
Some (List.find (xml_element_has_name name) elements)
48
(** Parses an XML element of the form "<name>value</value>". *)
49
(** Returns a (name, value) string pair, where the arguments *)
50
(** are stripped of leading and trailing whitespace. *)
51
let hash_table_entry_of_leaf_xml_element = function
52
| Xml.Element (name, _, Xml.PCData (value) :: values) ->
54
String.strip String.isspace name,
55
String.strip String.isspace value
57
| Xml.Element (name, _, []) -> Some (String.strip String.isspace name, "")
60
(** Parses a list of XML elements of the form: *)
61
(** <name0>value0</name0> *)
62
(** <name1>value1</name1> *)
63
(** <name2>value2</name2> *)
65
(** Returns a string hash table with an entry for *)
66
(** each element matched: *)
67
(** (name0 -> value0) *)
68
(** (name1 -> value1) *)
69
(** (name2 -> value2) *)
71
let hash_table_of_leaf_xml_element_list list =
73
List.filter_map hash_table_entry_of_leaf_xml_element list
76
(* === Daemon configuration === *)
78
module DaemonConfiguration = struct
80
(* Taken from Marathon's spec section 4.1.4.4 *)
81
let filename = "/etc/xensource/xhad.conf"
90
(** Simple type convertor. *)
91
let of_host_t host_t = {
92
uuid = host_t.host_uuid ;
93
address = host_t.host_address;
96
(** Converts the given HA daemon host configuration *)
97
(** into an XML element tree. *)
98
let to_xml_element host =
101
(xml_leaf_element "HostID" host.uuid );
102
(xml_leaf_element "IPaddress" host.address);
109
common_generation_uuid : string;
110
common_udp_port : int;
111
common_hosts : Host.t list;
112
local_host_uuid : string;
113
local_heart_beat_interface : string;
114
local_heart_beat_physical_interface : string;
115
local_state_file : string;
116
heart_beat_interval : int option;
117
state_file_interval : int option;
118
heart_beat_timeout : int option;
119
state_file_timeout : int option;
120
heart_beat_watchdog_timeout : int option;
121
state_file_watchdog_timeout : int option;
122
boot_join_timeout : int option;
123
enable_join_timeout : int option;
124
xapi_healthcheck_interval : int option;
125
xapi_healthcheck_timeout : int option;
126
xapi_restart_attempts : int option;
127
xapi_restart_timeout : int option;
128
xapi_licensecheck_timeout : int option;
131
(** See interface. *)
133
?(common_udp_port = 49154)
138
?heart_beat_watchdog_timeout
139
?state_file_watchdog_timeout
142
?xapi_healthcheck_interval
143
?xapi_healthcheck_timeout
144
?xapi_restart_attempts
145
?xapi_restart_timeout
146
?xapi_licensecheck_timeout
147
~common_generation_uuid
148
~local_heart_beat_interface
149
~local_heart_beat_physical_interface
153
let records = Db.Host.get_all_records ~__context in
154
let common_hosts = List.map
155
(fun (_, host) -> Host.of_host_t host)
157
let local_host_uuid =
159
~__context ~self:!Xapi_globs.localhost_ref in
161
common_hosts = common_hosts;
162
common_generation_uuid = (Uuid.to_string common_generation_uuid);
163
common_udp_port = common_udp_port;
164
local_host_uuid = local_host_uuid;
165
local_heart_beat_interface = local_heart_beat_interface;
166
local_heart_beat_physical_interface = local_heart_beat_physical_interface;
167
local_state_file = local_state_file;
168
heart_beat_interval = heart_beat_interval;
169
state_file_interval = state_file_interval;
170
heart_beat_timeout = heart_beat_timeout;
171
state_file_timeout = state_file_timeout;
172
heart_beat_watchdog_timeout = heart_beat_watchdog_timeout;
173
state_file_watchdog_timeout = state_file_watchdog_timeout;
174
boot_join_timeout = boot_join_timeout;
175
enable_join_timeout = enable_join_timeout;
176
xapi_healthcheck_interval = xapi_healthcheck_interval;
177
xapi_healthcheck_timeout = xapi_healthcheck_timeout;
178
xapi_restart_attempts = xapi_restart_attempts;
179
xapi_restart_timeout = xapi_restart_timeout;
180
xapi_licensecheck_timeout = xapi_licensecheck_timeout;
183
let int_parameter (name, param) =
184
Opt.default [] (Opt.map (fun x -> [ xml_leaf_element name (string_of_int x) ]) param)
186
(** Converts the given HA daemon configuration *)
187
(** into an XML element tree. *)
188
let to_xml_element config = Xml.Element (
190
[("version", "1.0")],
194
xml_leaf_element "GenerationUUID" ( config.common_generation_uuid) ::
195
xml_leaf_element "UDPport" (string_of_int config.common_udp_port ) ::
196
List.map Host.to_xml_element config.common_hosts @
198
Xml.Element ("parameters", [],
199
List.concat (List.map int_parameter
200
[ "HeartbeatInterval", config.heart_beat_interval;
201
"HeartbeatTimeout", config.heart_beat_timeout;
202
"StateFileInterval", config.state_file_interval;
203
"StateFileTimeout", config.state_file_timeout;
204
"HeartbeatWatchdogTimeout", config.heart_beat_watchdog_timeout;
205
"StateFileWatchdogTimeout", config.state_file_watchdog_timeout;
206
"BootJoinTimeout", config.boot_join_timeout;
207
"EnableJoinTimeout", config.enable_join_timeout;
208
"XapiHealthCheckInterval", config.xapi_healthcheck_interval;
209
"XapiHealthCheckTimeout", config.xapi_healthcheck_timeout;
210
"XapiRestartAttempts", config.xapi_restart_attempts;
211
"XapiRestartTimeout", config.xapi_restart_timeout;
212
"XapiLicenseCheckTimeout", config.xapi_licensecheck_timeout;
223
xml_leaf_element "HostID" config.local_host_uuid ;
224
xml_leaf_element "HeartbeatInterface" config.local_heart_beat_interface;
225
xml_leaf_element "HeartbeatPhysicalInterface" config.local_heart_beat_physical_interface;
226
xml_leaf_element "StateFile" config.local_state_file ;
234
(** Converts the given HA daemon configuration *)
235
(** into an XML string. *)
236
let to_xml_string config =
237
"<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" ^ (
239
to_xml_element config
245
(* === Live Set Information === *)
247
module LiveSetInformation = struct
249
module Status = struct
251
type t = Online | Offline | Starting
253
let of_string string =
254
match String.lowercase string with
255
| "online" -> Some (Online)
256
| "offline" -> Some (Offline)
257
| "starting" -> Some Starting
258
| _ -> invalid_arg "Invalid status string."
260
let to_string = function
262
| Offline -> "offline"
263
| Starting -> "starting"
273
state_file_access: bool;
274
state_file_corrupted: bool;
278
(** Creates a new host record from a host XML element. *)
279
(** The element must contain valid child elements for *)
280
(** each member of the host record type. *)
281
let of_xml_element = function
282
| Xml.Element ("host", _, children) ->
284
let table = hash_table_of_leaf_xml_element_list children in
286
try Hashtbl.find table x
288
invalid_arg (Printf.sprintf "Missig entry '%s' within 'host' element" x) in
290
try bool_of_string (String.lowercase s)
291
with Invalid_argument _ ->
292
invalid_arg (Printf.sprintf "Invalid boolean value '%s' within 'host' element" s) in
294
let uuid = Uuid.of_string in
296
id = uuid (find "HostID" );
297
liveness = bool (find "liveness" );
298
master = bool (find "master" );
299
state_file_access = bool (find "statefile_access" );
300
state_file_corrupted = bool (find "statefile_corrupted");
301
excluded = bool (find "excluded" )
309
module HostRawData = struct
312
time_since_last_update_on_statefile: int;
313
time_since_last_heartbeat: int;
314
time_since_xapi_restart_first_attempted: int;
315
heartbeat_active_list_on_heartbeat: [`host] Uuid.t list;
316
heartbeat_active_list_on_statefile: [`host] Uuid.t list;
319
let of_xml_element = function
320
| Xml.Element("host_raw_data", _, children) ->
321
let table = hash_table_of_leaf_xml_element_list children in
323
try Hashtbl.find table x
325
invalid_arg (Printf.sprintf "Missing entry '%s' within 'host_raw_data' element" x) in
327
try int_of_string (String.lowercase s)
328
with Invalid_argument _ ->
329
invalid_arg (Printf.sprintf "Invalid integer value '%s' within 'host_raw_data' element" s) in
330
let uuid = Uuid.of_string in
331
let set f x = List.map f (String.split_f String.isspace x) in
333
id = uuid (find "HostID");
334
time_since_last_update_on_statefile = int (find "time_since_last_update_on_statefile" );
335
time_since_last_heartbeat = int (find "time_since_last_heartbeat" );
336
time_since_xapi_restart_first_attempted = int (find "time_since_xapi_restart_first_attempted");
337
heartbeat_active_list_on_heartbeat = set uuid (find "heartbeat_active_list_on_heartbeat");
338
heartbeat_active_list_on_statefile = set uuid (find "heartbeat_active_list_on_statefile");
344
module Warning = struct
346
statefile_lost: bool;
347
heartbeat_approaching_timeout: bool;
348
statefile_approaching_timeout: bool;
349
xapi_healthcheck_approaching_timeout: bool;
350
network_bonding_error: bool;
352
let of_xml_element = function
353
| Xml.Element("warning_on_local_host", _, children) ->
355
let table = hash_table_of_leaf_xml_element_list children in
357
try Hashtbl.find table x
359
invalid_arg (Printf.sprintf "Missing entry '%s' within 'warning_on_local_host' element" x) in
360
let bool x = find x = "TRUE" in
362
statefile_lost = bool "statefile_lost";
363
heartbeat_approaching_timeout = bool "heartbeat_approaching_timeout";
364
statefile_approaching_timeout = bool "statefile_approaching_timeout";
365
xapi_healthcheck_approaching_timeout = bool "Xapi_healthcheck_approaching_timeout";
366
network_bonding_error = bool "network_bonding_error";
373
module RawStatus = struct
375
statefile_latency: int;
378
heartbeat_latency: int;
381
xapi_healthcheck_latency: int;
382
xapi_healthcheck_min: int;
383
xapi_healthcheck_max: int;
384
host_raw_data: ([`host] Uuid.t, HostRawData.t) Hashtbl.t;
386
let of_xml_element = function
387
| Xml.Element("raw_status_on_local_host", _, children) ->
389
let table = hash_table_of_leaf_xml_element_list children in
391
try Hashtbl.find table x
393
invalid_arg (Printf.sprintf "Missing entry '%s' within 'raw_status_on_local_host' element" x) in
395
try int_of_string (String.lowercase s)
396
with Invalid_argument _ ->
397
invalid_arg (Printf.sprintf "Invalid integer value '%s' within 'raw_status_on_local_host' element" s) in
398
let host_raw_data = Hashtbl.of_list (
400
(fun host -> (host.HostRawData.id, host))
401
(List.filter_map HostRawData.of_xml_element children)
405
statefile_latency = int (find "statefile_latency" );
406
statefile_min = int (find "statefile_latency_min" );
407
statefile_max = int (find "statefile_latency_max" );
408
heartbeat_latency = int (find "heartbeat_latency" );
409
heartbeat_min = int (find "heartbeat_latency_min" );
410
heartbeat_max = int (find "heartbeat_latency_max" );
411
xapi_healthcheck_latency = int (find "Xapi_healthcheck_latency" );
412
xapi_healthcheck_min = int (find "Xapi_healthcheck_latency_min");
413
xapi_healthcheck_max = int (find "Xapi_healthcheck_latency_max");
414
host_raw_data = host_raw_data;
425
local_host_id: [`host] Uuid.t;
426
hosts: ([`host] Uuid.t, Host.t) Hashtbl.t;
427
raw_status_on_local_host: RawStatus.t option;
428
warning_on_local_host: Warning.t option;
431
(** Creates a new HA live set information record *)
432
(** from the given list of XML elements. *)
433
let of_xml_element_list elements = {
434
hosts = Hashtbl.of_list (
436
(fun host -> (host.Host.id, host))
437
(List.filter_map Host.of_xml_element elements)
440
match first_xml_element_with_name elements "localhost" with
442
(_, _ , [Xml.Element ("HostID", _, [Xml.PCData (local_host_id)])]) ->
443
Uuid.of_string local_host_id
445
invalid_arg "Invalid or missing 'localhost' element."
449
match first_xml_element_with_name elements "status" with
450
| Some Xml.Element (_, _, [Xml.PCData (status_string)]) ->
451
Status.of_string status_string
454
match status_option with
455
| Some (status) -> status
456
| _ -> invalid_arg "Invalid or missing 'status' element."
458
raw_status_on_local_host = (
459
match first_xml_element_with_name elements "raw_status_on_local_host" with
460
| Some x -> RawStatus.of_xml_element x
463
warning_on_local_host = (
464
match first_xml_element_with_name elements "warning_on_local_host" with
465
| Some x -> Warning.of_xml_element x
470
(** Creates a new HA live set information record *)
471
(** from the given root XML element. *)
472
let of_xml_element = function
473
| Xml.Element ("ha_liveset_info", _, children) ->
474
of_xml_element_list children
476
invalid_arg "Invalid or missing 'ha_liveset_info' element."
478
(** See interface. *)
479
let of_xml_string string =
480
of_xml_element (Xml.parse_string string)
482
(** See interface. *)
483
let to_summary_string t =
484
let status = Status.to_string t.status in
485
let host h = Printf.sprintf "%s [%s%s%s%s%s%s]"
486
(Uuid.string_of_uuid h.Host.id)
487
(if h.Host.id = t.local_host_id then "*" else " ")
488
(if h.Host.liveness then "L" else " ")
489
(if h.Host.master then "M" else " ")
490
(if h.Host.excluded then "X" else " ")
491
(if h.Host.state_file_access then "A" else " ")
492
(if h.Host.state_file_corrupted then "X" else " ") in
493
status ^ " " ^ (Hashtbl.fold (fun _ h acc -> host h ^ "; " ^ acc) t.hosts "")
497
(* === Common I/O operations === *)
499
(** Reads all lines from a input channel. *)
500
let string_of_channel input_channel =
501
let rec string_of_channel input_channel input =
503
let line = input_line input_channel in
504
string_of_channel input_channel (input ^ line ^ "\n")
508
string_of_channel input_channel ""
510
(** Reads all lines from a file. *)
511
let string_of_file file_path=
512
let input_channel = open_in file_path in
513
string_of_channel input_channel
515
(* === Daemon configuration test === *)
517
module DaemonConfigurationTest = struct
519
include DaemonConfiguration
521
module HostTest = struct
526
uuid = "3a0d6864-42c6-4f82-8df9-d4cf3d747e2c";
530
uuid = "96044fa9-2b43-444a-b764-f94fe10a5dec";
534
uuid = "0447c77b-dc3f-4e75-8b97-eafb79a350fe";
538
uuid = "7d9217cf-d59c-4b72-8116-7f860d4089c1";
541
let mock_hosts = [mock_host_0; mock_host_1; mock_host_2; mock_host_3]
549
common_hosts = HostTest.mock_hosts ;
550
common_generation_uuid = "bac1a32e-8598-4aea-ba21-e13682e436d6";
551
common_udp_port = 1234 ;
552
local_host_uuid ="d45bd9d2-e0db-4a91-80f8-371de132c33e" ;
553
local_heart_beat_interface = "xebr0" ;
554
local_state_file ="/dev/xvde" ;
556
$ DaemonConfiguration.to_xml_string
561
(* === Live set information test === *)
563
module LiveSetInformationTest = struct
565
include LiveSetInformation
567
module HostTest = struct
573
"id = " ^ (Uuid.to_string host.id ) ^ "; " ^
574
"liveness = " ^ (string_of_bool host.liveness ) ^ "; " ^
575
"master = " ^ (string_of_bool host.master ) ^ "; " ^
576
"state_file_access = " ^ (string_of_bool host.state_file_access ) ^ "; " ^
577
"state_file_corrupted = " ^ (string_of_bool host.state_file_corrupted) ^ "; " ^
578
"excluded = " ^ (string_of_bool host.excluded ) ^
585
"status = " ^ (Status.to_string info.status ) ^ "; " ^
586
"local_host_id = " ^ (Uuid.to_string info.local_host_id ) ^ "; " ^
589
List.map (HostTest.to_string) (Hashtbl.fold_values info.hosts)
597
if Array.length Sys.argv != 2 then
598
print_endline "usage: xha_interface <path-to-xml-file>"
602
$ LiveSetInformation.of_xml_string
added
removed
ocaml/xapi/xha_interface.ml
