forked from xapi-project/xen-api
-
Notifications
You must be signed in to change notification settings - Fork 0
/
xapi_host.ml
1486 lines (1290 loc) · 68.8 KB
/
xapi_host.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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
* 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.
*)
module Rrdd = Rrd_client.Client
open Fun
open Pervasiveext
open Xstringext
open Listext
open Threadext
open Xapi_host_helpers
open Xapi_support
open Db_filter_types
open Create_misc
open Network
module D = Debug.Make(struct let name="xapi" end)
open D
let host_bugreport_upload = Filename.concat Fhs.libexecdir "host-bugreport-upload"
let set_hostname = Filename.concat Fhs.libexecdir "set-hostname"
let set_emergency_mode_error code params = Xapi_globs.emergency_mode_error := Api_errors.Server_error(code, params)
let local_assert_healthy ~__context = match Pool_role.get_role () with
| Pool_role.Master -> ()
| Pool_role.Broken -> raise !Xapi_globs.emergency_mode_error
| Pool_role.Slave _ -> if !Xapi_globs.slave_emergency_mode then raise !Xapi_globs.emergency_mode_error
let set_power_on_mode ~__context ~self ~power_on_mode ~power_on_config =
Db.Host.set_power_on_mode ~__context ~self ~value:power_on_mode;
let current_config=Db.Host.get_power_on_config ~__context ~self in
Db.Host.set_power_on_config ~__context ~self ~value:power_on_config;
Xapi_secret.clean_out_passwds ~__context current_config;
Xapi_host_helpers.update_allowed_operations ~__context ~self
(** Before we re-enable this host we make sure it's safe to do so. It isn't if:
+ we're in the middle of an HA shutdown/reboot and have our fencing temporarily disabled.
+ xapi hasn't properly started up yet.
+ HA is enabled and this host has broken storage or networking which would cause protected VMs
to become non-agile
*)
let assert_safe_to_reenable ~__context ~self =
assert_startup_complete ();
let host_disabled_until_reboot = try bool_of_string (Localdb.get Constants.host_disabled_until_reboot) with _ -> false in
if host_disabled_until_reboot
then raise (Api_errors.Server_error(Api_errors.host_disabled_until_reboot, []));
if Db.Pool.get_ha_enabled ~__context ~self:(Helpers.get_pool ~__context) then begin
let pbds = Db.Host.get_PBDs ~__context ~self in
let unplugged_pbds = List.filter (fun pbd -> not(Db.PBD.get_currently_attached ~__context ~self:pbd)) pbds in
(* Make sure it is 'ok' to have these PBDs remain unplugged *)
List.iter (fun self -> Xapi_pbd.abort_if_storage_attached_to_protected_vms ~__context ~self) unplugged_pbds;
let pifs = Db.Host.get_PIFs ~__context ~self in
let unplugged_pifs = List.filter (fun pif -> not(Db.PIF.get_currently_attached ~__context ~self:pif)) pifs in
(* Make sure it is 'ok' to have these PIFs remain unplugged *)
List.iter (fun self -> Xapi_pif.abort_if_network_attached_to_protected_vms ~__context ~self) unplugged_pifs;
end
let xen_bugtool = "/usr/sbin/xen-bugtool"
let bugreport_upload ~__context ~host ~url ~options =
let proxy =
if List.mem_assoc "http_proxy" options
then List.assoc "http_proxy" options
else try Unix.getenv "http_proxy" with _ -> "" in
let cmd = Printf.sprintf "%s %s %s" host_bugreport_upload url proxy in
try
let stdout, stderr = Forkhelpers.execute_command_get_output host_bugreport_upload [ url; proxy ] in
debug "%s succeeded with stdout=[%s] stderr=[%s]" cmd stdout stderr
with Forkhelpers.Spawn_internal_error(stderr, stdout, status) as e ->
debug "%s failed with stdout=[%s] stderr=[%s]" cmd stdout stderr;
(* Attempt to interpret curl's exit code (from curl(1)) *)
begin match status with
| Unix.WEXITED (1 | 3 | 4) ->
failwith "URL not recognised"
| Unix.WEXITED (5 | 6) ->
failwith "Failed to resolve proxy or host"
| Unix.WEXITED 7 ->
failwith "Failed to connect to host"
| Unix.WEXITED 9 ->
failwith "FTP access denied"
| _ -> raise e
end
(** Check that a) there are no running VMs present on the host, b) there are no VBDs currently
attached to dom0, c) host is disabled.
This is approximately maintainance mode as defined by the gui. However, since
we haven't agreed on an exact definition of this mode, we'll not call this maintainance mode here, but we'll
use a synonym. According to http://thesaurus.com/browse/maintenance, bacon is a synonym
for maintainance, hence the name of the following function.
*)
let assert_bacon_mode ~__context ~host =
if Db.Host.get_enabled ~__context ~self:host
then raise (Api_errors.Server_error (Api_errors.host_not_disabled, []));
let selfref = Ref.string_of host in
let vms = Db.VM.get_refs_where ~__context ~expr:(And(Eq (Field "resident_on", Literal (Ref.string_of host)),
Eq (Field "power_state", Literal "Running"))) in
(* We always expect a control domain to be resident on a host *)
(match List.filter (fun vm -> not (Db.VM.get_is_control_domain ~__context ~self:vm)) vms with
| [] -> ()
| guest_vms ->
let vm_data = [selfref; "vm"; Ref.string_of (List.hd guest_vms)] in
raise (Api_errors.Server_error (Api_errors.host_in_use, vm_data)));
debug "Bacon test: VMs OK - %d running VMs" (List.length vms);
let controldomain = List.find (fun vm -> Db.VM.get_resident_on ~__context ~self:vm = host &&
Db.VM.get_is_control_domain ~__context ~self:vm) (Db.VM.get_all ~__context) in
let vbds = List.filter (fun vbd -> Db.VBD.get_VM ~__context ~self:vbd = controldomain &&
Db.VBD.get_currently_attached ~__context ~self:vbd) (Db.VBD.get_all ~__context) in
if List.length vbds > 0 then
raise (Api_errors.Server_error (Api_errors.host_in_use, [ selfref; "vbd"; List.hd (List.map Ref.string_of vbds) ]));
debug "Bacon test: VBDs OK"
let signal_networking_change ~__context =
Helpers.update_pif_addresses ~__context;
Xapi_mgmt_iface.on_dom0_networking_change ~__context
let signal_cdrom_event ~__context params =
let find_vdi_name sr name =
let ret = ref None in
let vdis = Db.SR.get_VDIs ~__context ~self:sr in
List.iter (fun vdi ->
if Db.VDI.get_location ~__context ~self:vdi = name then ret := Some vdi
) vdis;
!ret
in
let find_vdis name =
let srs = List.filter (fun sr ->
let ty = Db.SR.get_type ~__context ~self:sr in ty = "local" || ty = "udev"
) (Db.SR.get_all ~__context) in
List.fold_left (fun acc o -> match o with Some x -> x :: acc | None -> acc) []
(List.map (fun sr -> find_vdi_name sr name) srs)
in
let insert dev =
let vdis = find_vdis dev in
if List.length vdis = 1 then (
let vdi = List.hd vdis in
debug "cdrom inserted notification in vdi %s" (Ref.string_of vdi);
let vbds = Db.VDI.get_VBDs ~__context ~self:vdi in
List.iter (fun vbd -> Xapi_xenops.vbd_insert ~__context ~self:vbd ~vdi) vbds
) else
()
in
try
match String.split ':' params with
| ["inserted";dev] -> insert dev
| "ejected"::_ -> ()
| _ -> ()
with _ ->
()
let notify ~__context ~ty ~params =
match ty with
| "cdrom" -> signal_cdrom_event ~__context params
| _ -> ()
let rotate = function
| [] -> []
| x::xs -> xs@[x]
(* A host evacuation plan consists of a hashtable mapping VM refs to instances of per_vm_plan: *)
type per_vm_plan =
| Migrate of API.ref_host
| Error of (string * string list)
let string_of_per_vm_plan p =
match p with
| Migrate h ->
Ref.string_of h
| Error (e, t) ->
String.concat "," (e :: t)
(** Return a table mapping VMs to 'per_vm_plan' types indicating either a target
Host or a reason why the VM cannot be migrated. *)
let compute_evacuation_plan_no_wlb ~__context ~host =
let all_hosts = Db.Host.get_all ~__context in
let enabled_hosts = List.filter (fun self -> Db.Host.get_enabled ~__context ~self) all_hosts in
(* Only consider migrating to other enabled hosts (not this one obviously) *)
let target_hosts = List.filter (fun self -> self <> host) enabled_hosts in
(* PR-1007: During a rolling pool upgrade, we are only allowed to
migrate VMs to hosts that have the same or higher version as
the source host. So as long as host versions aren't decreasing,
we're allowed to migrate VMs between hosts. *)
debug "evacuating host version: %s"
(Helpers.version_string_of ~__context (Helpers.LocalObject host));
let target_hosts = List.filter
(fun target ->
debug "host %s version: %s"
(Db.Host.get_hostname ~__context ~self:target)
(Helpers.version_string_of ~__context (Helpers.LocalObject target)) ;
Helpers.host_versions_not_decreasing ~__context
~host_from:(Helpers.LocalObject host)
~host_to:(Helpers.LocalObject target))
target_hosts
in
debug "evacuation target hosts are [%s]"
(String.concat "; " (List.map (fun h -> Db.Host.get_hostname ~__context ~self:h) target_hosts)) ;
let all_vms = Db.Host.get_resident_VMs ~__context ~self:host in
let all_vms = List.map (fun self -> self, Db.VM.get_record ~__context ~self) all_vms in
let all_user_vms = List.filter (fun (_, record) -> not record.API.vM_is_control_domain) all_vms in
let plans = Hashtbl.create 10 in
if target_hosts = []
then
begin
List.iter (fun (vm, _) ->
Hashtbl.add plans vm (Error (Api_errors.no_hosts_available, [ Ref.string_of vm ])))
all_user_vms ;
plans
end
else
begin
(* If HA is enabled we require that non-protected VMs are suspended. This gives us the property that
the result obtained by executing the evacuation plan and disabling the host looks the same (from the HA
planner's PoV) to the result obtained following a host failure and VM restart. *)
let pool = Helpers.get_pool ~__context in
let protected_vms, unprotected_vms =
if Db.Pool.get_ha_enabled ~__context ~self:pool
then List.partition (fun (vm, record) ->
Helpers.vm_should_always_run record.API.vM_ha_always_run record.API.vM_ha_restart_priority)
all_user_vms
else all_user_vms, [] in
List.iter (fun (vm, _) ->
Hashtbl.replace plans vm (Error (Api_errors.host_not_enough_free_memory, [ Ref.string_of vm ])))
unprotected_vms;
let migratable_vms, unmigratable_vms = List.partition (fun (vm, record) ->
begin
try
List.iter (fun host ->
Xapi_vm_helpers.assert_can_boot_here ~__context ~self:vm ~host ~snapshot:record
~do_memory_check:false ())
target_hosts;
true
with (Api_errors.Server_error (code, params)) -> Hashtbl.replace plans vm (Error (code, params)); false
end) protected_vms in
(* Check for impediments before attempting to perform pool_migrate *)
List.iter
(fun (vm, _) ->
match Xapi_vm_lifecycle.get_operation_error ~__context ~self:vm ~op:`pool_migrate with
| None -> ()
| Some (a,b) -> Hashtbl.replace plans vm (Error ( a, b))
)all_user_vms;
(* Check for the presence of PV drivers that support migration. *)
List.iter
(fun (vm, vm_record) ->
let pv_driver_version =
Xapi_pv_driver_version.of_guest_metrics
(Opt.of_exception (fun () ->
Db.VM_guest_metrics.get_record_internal
~__context ~self:vm_record.API.vM_guest_metrics)) in
let pv_drivers_error =
if not (Helpers.has_booted_hvm ~__context ~self:vm)
then None (* PV guests don't need driver check *)
else (* HVM guest do *)
if Xapi_pv_driver_version.is_ok_for_migrate pv_driver_version
then None
else Some Api_errors.vm_missing_pv_drivers in
Opt.iter
(fun e -> Hashtbl.replace plans vm (Error (e, [Ref.string_of vm])))
(pv_drivers_error))
(all_user_vms);
(* Compute the binpack which takes only memory size into account. We will check afterwards for storage
and network availability. *)
let plan = Xapi_ha_vm_failover.compute_evacuation_plan ~__context (List.length all_hosts) target_hosts migratable_vms in
(* Check if the plan was actually complete: if some VMs are missing it means there wasn't enough memory *)
let vms_handled = List.map fst plan in
let vms_missing = List.filter (fun x -> not(List.mem x vms_handled)) (List.map fst protected_vms) in
List.iter (fun vm -> Hashtbl.add plans vm (Error (Api_errors.host_not_enough_free_memory, [ Ref.string_of vm ]))) vms_missing;
(* Now for each VM we did place, verify storage and network visibility. *)
List.iter (fun (vm, host) ->
let snapshot = List.assoc vm all_vms in
begin
try Xapi_vm_helpers.assert_can_boot_here ~__context ~self:vm ~host ~snapshot ~do_memory_check:false ()
with (Api_errors.Server_error (code, params)) -> Hashtbl.replace plans vm (Error (code, params))
end;
if not(Hashtbl.mem plans vm) then Hashtbl.add plans vm (Migrate host)
) plan;
plans
end
(* Old Miami style function with the strange error encoding *)
let assert_can_evacuate ~__context ~host =
(* call no_wlb function as we only care about errors, and wlb only provides recs for moveable vms *)
let plans = compute_evacuation_plan_no_wlb ~__context ~host in
let errors = Hashtbl.fold (fun vm plan acc -> match plan with Error(code, params) -> String.concat "," (code::params) :: acc | _ -> acc) plans [] in
if errors <> []
then raise (Api_errors.Server_error (Api_errors.cannot_evacuate_host, [ String.concat "|" errors ]))
(* New Orlando style function which returns a Map *)
let get_vms_which_prevent_evacuation ~__context ~self =
let plans = compute_evacuation_plan_no_wlb ~__context ~host:self in
Hashtbl.fold (fun vm plan acc -> match plan with Error(code, params) -> (vm, (code :: params)) :: acc | _ -> acc) plans []
let compute_evacuation_plan ~__context ~host =
compute_evacuation_plan_no_wlb ~__context ~host
let evacuate ~__context ~host =
let task = Context.get_task_id __context in
begin
let plans = compute_evacuation_plan ~__context ~host in
(* Check there are no errors in this list *)
Hashtbl.iter (fun vm plan ->
match plan with
| Error(code, params) -> raise (Api_errors.Server_error(code, params))
| _ -> ())
plans;
(* Do it *)
let individual_progress = 1.0 /. float (Hashtbl.length plans) in
let migrate_vm vm plan = match plan with
| Migrate host ->
(try
Helpers.call_api_functions ~__context
(fun rpc session_id -> Client.Client.VM.pool_migrate
~rpc ~session_id ~vm ~host ~options:[ "live", "true" ])
with
|Api_errors.Server_error(code, params) when code = Api_errors.vm_bad_power_state -> ()
| e -> raise e
);
let progress = Db.Task.get_progress ~__context ~self:task in
TaskHelper.set_progress ~__context (progress +. individual_progress)
| Error(code, params) -> (* should never happen *)
raise (Api_errors.Server_error(code, params))
in
let () = Hashtbl.iter migrate_vm plans in
(* Now check there are no VMs left *)
let vms = Db.Host.get_resident_VMs ~__context ~self:host in
let vms =
List.filter
(fun vm ->
not (Db.VM.get_is_control_domain ~__context ~self:vm))
vms
in
assert (List.length vms = 0)
end
let restart_agent ~__context ~host =
let cmd = Filename.concat Fhs.bindir "xe-toolstack-restart" in
let syslog_stdout = Forkhelpers.Syslog_WithKey ("Host.restart_agent") in
let pid = Forkhelpers.safe_close_and_exec None None None [] ~syslog_stdout cmd [] in
debug "Created process with pid: %d to perform xe-toolstack-restart" (Forkhelpers.getpid pid)
let shutdown_agent ~__context =
debug "Host.restart_agent: Host agent will shutdown in 1s!!!!";
Xapi_fuse.light_fuse_and_dont_restart ~fuse_length:1. ()
let disable ~__context ~host =
if Db.Host.get_enabled ~__context ~self:host then begin
info "Host.enabled: setting host %s (%s) to disabled because of user request" (Ref.string_of host) (Db.Host.get_hostname ~__context ~self:host);
Db.Host.set_enabled ~__context ~self:host ~value:false;
Xapi_host_helpers.user_requested_host_disable := true
end
let enable ~__context ~host =
if not (Db.Host.get_enabled ~__context ~self:host) then begin
assert_safe_to_reenable ~__context ~self:host;
Xapi_host_helpers.user_requested_host_disable := false;
info "Host.enabled: setting host %s (%s) to enabled because of user request" (Ref.string_of host) (Db.Host.get_hostname ~__context ~self:host);
Db.Host.set_enabled ~__context ~self:host ~value:true;
(* Normally we schedule a plan recomputation when we successfully plug in our storage. In the case
when some of our storage was broken and required maintenance, we end up here, manually re-enabling
the host. If we're overcommitted then this might fix the problem. *)
let pool = Helpers.get_pool ~__context in
if Db.Pool.get_ha_enabled ~__context ~self:pool && Db.Pool.get_ha_overcommitted ~__context ~self:pool
then Helpers.call_api_functions ~__context (fun rpc session_id -> Client.Client.Pool.ha_schedule_plan_recomputation rpc session_id)
end
let shutdown_and_reboot_common ~__context ~host label description operation cmd =
if Db.Host.get_enabled ~__context ~self:host
then raise (Api_errors.Server_error (Api_errors.host_not_disabled, []));
Xapi_ha.before_clean_shutdown_or_reboot ~__context ~host;
Remote_requests.stop_request_thread();
(* Push the Host RRD to the master. Note there are no VMs running here so we don't have to worry about them. *)
if not(Pool_role.is_master ())
then log_and_ignore_exn Rrdd.send_host_rrd_to_master;
(* Also save the Host RRD to local disk for us to pick up when we return. Note there are no VMs running at this point. *)
log_and_ignore_exn Rrdd.backup_rrds;
(* This prevents anyone actually re-enabling us until after reboot *)
Localdb.put Constants.host_disabled_until_reboot "true";
(* This helps us distinguish between an HA fence and a reboot *)
Localdb.put Constants.host_restarted_cleanly "true";
(* This tells the master that the shutdown is still ongoing: it can be used to continue
masking other operations even after this call return.
If xapi restarts then this task will be reset by the startup code, which is unfortunate
but the host will stay disabled provided host_disabled_until_reboot is still set... so
safe but ugly. *)
Server_helpers.exec_with_new_task ~subtask_of:(Context.get_task_id __context) ~task_description:description ~task_in_database:true label (fun __newcontext ->
Db.Host.add_to_current_operations ~__context ~self:host ~key:(Ref.string_of (Context.get_task_id __newcontext)) ~value:operation;
(* Do the shutdown in a background thread with a delay to give this API call
a reasonable chance of succeeding. *)
ignore(Thread.create (fun () ->
Thread.delay 10.;
ignore(Sys.command cmd)) ()))
let shutdown ~__context ~host =
shutdown_and_reboot_common ~__context ~host "Host is shutting down" "Host is shutting down"
`shutdown "/sbin/shutdown -h now"
let reboot ~__context ~host =
shutdown_and_reboot_common ~__context ~host "Host is rebooting" "Host is rebooting"
`shutdown "/sbin/shutdown -r now"
let power_on ~__context ~host =
let result = Xapi_plugins.call_plugin (Context.get_session_id __context)
Constants.power_on_plugin Constants.power_on_fn
[ "remote_host_uuid", Db.Host.get_uuid ~__context ~self:host ] in
if result <> "True" then failwith (Printf.sprintf "The host failed to power on.")
let dmesg ~__context ~host =
let open Xenops_client in
let dbg = Context.string_of_task __context in
Client.HOST.get_console_data dbg
let dmesg_clear ~__context ~host =
raise (Api_errors.Server_error (Api_errors.not_implemented, [ "dmesg_clear" ]))
let get_log ~__context ~host =
raise (Api_errors.Server_error (Api_errors.not_implemented, [ "get_log" ]))
let send_debug_keys ~__context ~host ~keys =
let open Xenops_client in
let dbg = Context.string_of_task __context in
Client.HOST.send_debug_keys dbg keys
let list_methods ~__context =
raise (Api_errors.Server_error (Api_errors.not_implemented, [ "list_method" ]))
let is_slave ~__context ~host = not (Pool_role.is_master ())
let ask_host_if_it_is_a_slave ~__context ~host =
let local_fn = is_slave ~host in
Message_forwarding.do_op_on_localsession_nolivecheck ~local_fn ~__context
~host (fun session_id rpc -> Client.Client.Pool.is_slave rpc session_id host)
let is_host_alive ~__context ~host =
(* If the host is marked as not-live then assume we don't need to contact it to verify *)
let should_contact_host =
try
let hm = Db.Host.get_metrics ~__context ~self:host in
Db.Host_metrics.get_live ~__context ~self:hm
with _ ->
true in
if should_contact_host then begin
debug "is_host_alive host=%s is marked as live in the database; asking host to make sure" (Ref.string_of host);
try
ignore(ask_host_if_it_is_a_slave ~__context ~host);
true
with e ->
warn "is_host_alive host=%s caught %s while querying host liveness: assuming dead"
(Ref.string_of host) (ExnHelper.string_of_exn e);
false
end else begin
debug "is_host_alive host=%s is marked as dead in the database; treating this as definitive." (Ref.string_of host);
false
end
let create ~__context ~uuid ~name_label ~name_description ~hostname ~address ~external_auth_type ~external_auth_service_name ~external_auth_configuration ~license_params ~edition ~license_server ~local_cache_sr ~chipset_info =
let make_new_metrics_object ref =
Db.Host_metrics.create ~__context ~ref
~uuid:(Uuid.to_string (Uuid.make_uuid ())) ~live:false
~memory_total:0L ~memory_free:0L ~last_updated:Date.never ~other_config:[] in
let name_description = "Default install of XenServer"
and host = Ref.make () in
let metrics = Ref.make () in
make_new_metrics_object metrics;
Db.Host.create ~__context ~ref:host
~current_operations:[] ~allowed_operations:[]
~software_version:Xapi_globs.software_version
~enabled:true
~aPI_version_major:Xapi_globs.api_version_major
~aPI_version_minor:Xapi_globs.api_version_minor
~aPI_version_vendor:Xapi_globs.api_version_vendor
~aPI_version_vendor_implementation:Xapi_globs.api_version_vendor_implementation
~name_description ~name_label ~uuid ~other_config:[]
~capabilities:[]
~cpu_configuration:[] (* !!! FIXME hard coding *)
~cpu_info:[]
~chipset_info
~memory_overhead:0L
~sched_policy:"credit" (* !!! FIXME hard coding *)
~supported_bootloaders:(List.map fst Xapi_globs.supported_bootloaders)
~suspend_image_sr:Ref.null ~crash_dump_sr:Ref.null
~logging:[] ~hostname ~address ~metrics
~license_params ~boot_free_mem:0L
~ha_statefiles:[] ~ha_network_peers:[] ~blobs:[] ~tags:[]
~external_auth_type
~external_auth_service_name
~external_auth_configuration
~edition ~license_server
~bios_strings:[]
~power_on_mode:""
~power_on_config:[]
~local_cache_sr
~guest_VCPUs_params:[]
;
(* If the host we're creating is us, make sure its set to live *)
Db.Host_metrics.set_last_updated ~__context ~self:metrics ~value:(Date.of_float (Unix.gettimeofday ()));
Db.Host_metrics.set_live ~__context ~self:metrics ~value:(uuid=(Helpers.get_localhost_uuid ()));
host
let precheck_destroy_declare_dead ~__context ~self call =
(* Fail if the host is still online: the user should either isolate the machine from the network
or use Pool.eject. *)
let hostname = Db.Host.get_hostname ~__context ~self in
if is_host_alive ~__context ~host:self then begin
error "Host.%s successfully contacted host %s; host is not offline; refusing to %s" call hostname call;
raise (Api_errors.Server_error(Api_errors.host_is_live, [ Ref.string_of self ]))
end;
(* This check is probably redundant since the Pool master should always be 'alive': *)
(* It doesn't make any sense to destroy the master's own record *)
let me = Helpers.get_localhost ~__context in
if self=me then raise (Api_errors.Server_error(Api_errors.host_is_live, [ Ref.string_of self ]))
(* Returns a tuple of lists: The first containing the control domains, and the second containing the regular VMs *)
let get_resident_vms ~__context ~self =
let my_resident_vms = Db.Host.get_resident_VMs ~__context ~self in
List.partition (fun vm -> Db.VM.get_is_control_domain ~__context ~self:vm) my_resident_vms
let destroy ~__context ~self =
precheck_destroy_declare_dead ~__context ~self "destroy";
(* CA-23732: Block if HA is enabled *)
let pool = Helpers.get_pool ~__context in
if Db.Pool.get_ha_enabled ~__context ~self:pool
then raise (Api_errors.Server_error(Api_errors.ha_is_enabled, []));
let my_control_domains, my_regular_vms = get_resident_vms ~__context ~self in
if List.length my_regular_vms > 0
then raise (Api_errors.Server_error(Api_errors.host_has_resident_vms, [ Ref.string_of self ]));
(* Call the hook before we destroy the stuff as it will likely need the
database records *)
Xapi_hooks.host_post_declare_dead ~__context ~host:self ~reason:Xapi_hooks.reason__dbdestroy;
Db.Host.destroy ~__context ~self;
List.iter (fun vm -> Db.VM.destroy ~__context ~self:vm) my_control_domains
let declare_dead ~__context ~host =
precheck_destroy_declare_dead ~__context ~self:host "declare_dead";
let my_control_domains, my_regular_vms = get_resident_vms ~__context ~self:host in
Helpers.call_api_functions ~__context (fun rpc session_id ->
List.iter (fun vm -> Client.Client.VM.power_state_reset rpc session_id vm) my_regular_vms);
Db.Host.set_enabled ~__context ~self:host ~value:false;
Xapi_hooks.host_post_declare_dead ~__context ~host ~reason:Xapi_hooks.reason__user
let ha_disable_failover_decisions ~__context ~host = Xapi_ha.ha_disable_failover_decisions __context host
let ha_disarm_fencing ~__context ~host = Xapi_ha.ha_disarm_fencing __context host
let ha_stop_daemon ~__context ~host = Xapi_ha.ha_stop_daemon __context host
let ha_release_resources ~__context ~host = Xapi_ha.ha_release_resources __context host
let ha_wait_for_shutdown_via_statefile ~__context ~host = Xapi_ha.ha_wait_for_shutdown_via_statefile __context host
let ha_xapi_healthcheck ~__context =
(* Consider checking the status of various internal tasks / tickling locks but for now assume
that, since we got here unharmed, all is well.*)
not(Xapi_fist.fail_healthcheck ())
let preconfigure_ha ~__context ~host ~statefiles ~metadata_vdi ~generation =
Xapi_ha.preconfigure_host __context host statefiles metadata_vdi generation
let ha_join_liveset ~__context ~host =
try
Xapi_ha.join_liveset __context host
with
| Xapi_ha.Xha_error Xha_errno.Mtc_exit_bootjoin_timeout ->
error "HA enable failed with BOOTJOIN_TIMEOUT";
raise (Api_errors.Server_error(Api_errors.ha_failed_to_form_liveset, []))
| Xapi_ha.Xha_error Xha_errno.Mtc_exit_can_not_access_statefile ->
error "HA enable failed with CAN_NOT_ACCESS_STATEFILE";
raise (Api_errors.Server_error(Api_errors.ha_host_cannot_access_statefile, []))
let propose_new_master ~__context ~address ~manual = Xapi_ha.propose_new_master __context address manual
let commit_new_master ~__context ~address = Xapi_ha.commit_new_master __context address
let abort_new_master ~__context ~address = Xapi_ha.abort_new_master __context address
let update_master ~__context ~host ~master_address = assert false
let emergency_ha_disable ~__context = Xapi_ha.emergency_ha_disable __context
(* This call can be used to _instruct_ a slave that it has to take a persistent backup (force=true).
If force=false then this is a hint from the master that the client may want to take a backup; in this
latter case the slave applies its write-limiting policy and compares generation counts to determine whether
it really should take a backup *)
let request_backup ~__context ~host ~generation ~force =
if Helpers.get_localhost ~__context <> host
then failwith "Forwarded to the wrong host";
if Pool_role.is_master () then begin
debug "Requesting database backup on master: Using direct sync";
let connections = Db_conn_store.read_db_connections () in
Db_cache_impl.sync connections (Db_ref.get_database (Db_backend.make ()))
end else begin
let master_address = Helpers.get_main_ip_address () in
Pool_db_backup.fetch_database_backup ~master_address:master_address ~pool_secret:!Xapi_globs.pool_secret
~force:(if force then None else (Some generation))
end
(* request_config_file_sync is used to inform a slave that it should consider resyncing dom0 config files
(currently only /etc/passwd) *)
let request_config_file_sync ~__context ~host ~hash =
debug "Received notification of dom0 config file change";
let master_address = Helpers.get_main_ip_address () in
Config_file_sync.fetch_config_files ~master_address:master_address ~pool_secret:!Xapi_globs.pool_secret
(* Host parameter will just be me, as message forwarding layer ensures this call has been forwarded correctly *)
let syslog_reconfigure ~__context ~host =
let localhost = Helpers.get_localhost ~__context in
let logging = Db.Host.get_logging ~__context ~self:localhost in
let destination = try List.assoc "syslog_destination" logging with _ -> "" in
let flag = match destination with
| "" ->
"--noremote"
| _ ->
"--remote="^destination
in
let args = [| Filename.concat Fhs.libexecdir "xe-syslog-reconfigure"; flag |] in
ignore (Unixext.spawnvp args.(0) args)
let get_management_interface ~__context ~host =
let pifs = Db.PIF.get_refs_where ~__context ~expr:(And (
Eq (Field "host", Literal (Ref.string_of host)),
Eq (Field "management", Literal "true")
)) in
match pifs with
| [] ->
raise Not_found
| pif :: _ ->
pif
let change_management_interface ~__context interface primary_address_type =
debug "Changing management interface";
Xapi_mgmt_iface.change interface primary_address_type;
Xapi_mgmt_iface.run ~__context ~mgmt_enabled:true;
(* once the inventory file has been rewritten to specify new interface, sync up db with
state of world.. *)
Xapi_mgmt_iface.on_dom0_networking_change ~__context
let local_management_reconfigure ~__context ~interface =
(* Only let this one through if we are in emergency mode, otherwise use
Host.management_reconfigure *)
if not !Xapi_globs.slave_emergency_mode
then raise (Api_errors.Server_error (Api_errors.pool_not_in_emergency_mode, []));
change_management_interface ~__context interface
(Record_util.primary_address_type_of_string (Xapi_inventory.lookup Xapi_inventory._management_address_type ~default:"ipv4"))
let management_reconfigure ~__context ~pif =
(* Disallow if HA is enabled *)
let pool = List.hd (Db.Pool.get_all ~__context) in
if Db.Pool.get_ha_enabled ~__context ~self:pool then
raise (Api_errors.Server_error(Api_errors.ha_is_enabled, []));
(* Plugging a bond slave is not allowed *)
if Db.PIF.get_bond_slave_of ~__context ~self:pif <> Ref.null then
raise (Api_errors.Server_error (Api_errors.cannot_plug_bond_slave, [Ref.string_of pif]));
let net = Db.PIF.get_network ~__context ~self:pif in
let bridge = Db.Network.get_bridge ~__context ~self:net in
let primary_address_type = Db.PIF.get_primary_address_type ~__context ~self:pif in
if Db.PIF.get_managed ~__context ~self:pif = true then begin
if primary_address_type = `IPv4 && Db.PIF.get_ip_configuration_mode ~__context ~self:pif = `None then
raise (Api_errors.Server_error(Api_errors.pif_has_no_network_configuration, []))
else if primary_address_type = `IPv6 && Db.PIF.get_ipv6_configuration_mode ~__context ~self:pif = `None then
raise (Api_errors.Server_error(Api_errors.pif_has_no_v6_network_configuration, []))
else try
let mgmt_pif = get_management_interface ~__context ~host:(Helpers.get_localhost ~__context) in
let mgmt_address_type = Db.PIF.get_primary_address_type ~__context ~self:mgmt_pif in
if primary_address_type <> mgmt_address_type then
raise (Api_errors.Server_error(Api_errors.pif_incompatible_primary_address_type, []));
with _ ->
() (* no current management interface *)
end;
if Db.PIF.get_management ~__context ~self:pif then
debug "PIF %s is already marked as a management PIF; taking no action" (Ref.string_of pif)
else begin
Xapi_network.attach_internal ~management_interface:true ~__context ~self:net ();
change_management_interface ~__context bridge primary_address_type;
Xapi_pif.update_management_flags ~__context ~host:(Helpers.get_localhost ~__context)
end
let management_disable ~__context =
(* Disallow if HA is enabled *)
let pool = List.hd (Db.Pool.get_all ~__context) in
if Db.Pool.get_ha_enabled ~__context ~self:pool
then raise (Api_errors.Server_error(Api_errors.ha_is_enabled, []));
(* Make sure we aren't about to disable our management interface on a slave *)
if Pool_role.is_slave ()
then raise (Api_errors.Server_error (Api_errors.slave_requires_management_iface, []));
(* Reset the management server *)
Xapi_mgmt_iface.change "" `IPv4;
Xapi_mgmt_iface.run ~__context ~mgmt_enabled:false;
(* Make sure all my PIFs are marked appropriately *)
Xapi_pif.update_management_flags ~__context ~host:(Helpers.get_localhost ~__context)
let get_system_status_capabilities ~__context ~host =
if Helpers.get_localhost ~__context <> host
then failwith "Forwarded to the wrong host";
System_status.get_capabilities()
let get_sm_diagnostics ~__context ~host = Storage_access.diagnostics ~__context
let get_thread_diagnostics ~__context ~host = Locking_helpers.Thread_state.to_graphviz ()
let sm_dp_destroy ~__context ~host ~dp ~allow_leak = Storage_access.dp_destroy ~__context dp allow_leak
let get_diagnostic_timing_stats ~__context ~host = Stats.summarise ()
(* CP-825: Serialize execution of host-enable-extauth and host-disable-extauth *)
(* We need to protect against concurrent execution of the extauth-hook script and host.enable/disable extauth, *)
(* because the extauth-hook script expects the auth_type, service_name etc to be constant throughout its execution *)
(* This mutex also serializes the execution of the plugin, to avoid concurrency problems when updating the sshd configuration *)
let serialize_host_enable_disable_extauth = Mutex.create()
let set_hostname_live ~__context ~host ~hostname =
Mutex.execute serialize_host_enable_disable_extauth (fun () ->
let current_auth_type = Db.Host.get_external_auth_type ~__context ~self:host in
(* the AD/Likewise extauth plugin is incompatible with a hostname change *)
(if current_auth_type = Extauth.auth_type_AD_Likewise then
let current_service_name = Db.Host.get_external_auth_service_name ~__context ~self:host in
raise (Api_errors.Server_error(Api_errors.auth_already_enabled, [current_auth_type;current_service_name]))
);
(* hostname is valid if contains only alpha, decimals, and hyphen
(for hyphens, only in middle position) *)
let is_invalid_hostname hostname =
let len = String.length hostname in
let i = ref 0 in
let valid = ref true in
let range = [ 'a', 'z'; 'A', 'Z'; '0', '9'; '-', '-'; '.', '.' ] in
while !valid && (!i < len)
do
begin try
ignore (List.find (fun (r1, r2) -> r1 <= hostname.[!i] && hostname.[!i] <= r2) range)
with Not_found ->
valid := false
end;
incr i;
done;
if hostname.[0] = '-' || hostname.[len - 1] = '-' then
true
else
(not !valid)
in
if String.length hostname = 0 then
raise (Api_errors.Server_error (Api_errors.host_name_invalid, [ "hostname empty" ]));
if String.length hostname > 255 then
raise (Api_errors.Server_error (Api_errors.host_name_invalid, [ "hostname is too long" ]));
if is_invalid_hostname hostname then
raise (Api_errors.Server_error (Api_errors.host_name_invalid, [ "hostname contains invalid characters" ]));
ignore(Forkhelpers.execute_command_get_output set_hostname [hostname]);
Debug.invalidate_hostname_cache ();
Db.Host.set_hostname ~__context ~self:host ~value:hostname
)
let is_in_emergency_mode ~__context =
!Xapi_globs.slave_emergency_mode
let compute_free_memory ~__context ~host =
(*** XXX: Use a more appropriate free memory calculation here. *)
Memory_check.host_compute_free_memory_with_maximum_compression
~dump_stats:false ~__context ~host None
let compute_memory_overhead ~__context ~host =
Memory_check.host_compute_memory_overhead ~__context ~host
let get_data_sources ~__context ~host = List.map Rrdd_helper.to_API_data_source (Rrdd.query_possible_host_dss ())
let record_data_source ~__context ~host ~data_source = Rrdd.add_host_ds ~ds_name:data_source
let query_data_source ~__context ~host ~data_source = Rrdd.query_host_ds ~ds_name:data_source
let forget_data_source_archives ~__context ~host ~data_source = Rrdd.forget_host_ds ~ds_name:data_source
let tickle_heartbeat ~__context ~host ~stuff = Db_gc.tickle_heartbeat ~__context host stuff
let create_new_blob ~__context ~host ~name ~mime_type ~public =
let blob = Xapi_blob.create ~__context ~mime_type ~public in
Db.Host.add_to_blobs ~__context ~self:host ~key:name ~value:blob;
blob
let extauth_hook_script_name = Extauth.extauth_hook_script_name
(* this special extauth plugin call is only used inside host.enable/disable extauth to avoid deadlock with the mutex *)
let call_extauth_plugin_nomutex ~__context ~host ~fn ~args =
let plugin = extauth_hook_script_name in
debug "Calling extauth plugin %s in host %s with event %s and params %s" plugin (Db.Host.get_name_label ~__context ~self:host) fn (List.fold_left (fun a (b,y)->a^"("^b^"="^y^"),") "" args);
Xapi_plugins.call_plugin (Context.get_session_id __context) plugin fn args
(* this is the generic extauth plugin call available to xapi users that avoids concurrency problems *)
let call_extauth_plugin ~__context ~host ~fn ~args =
Mutex.execute serialize_host_enable_disable_extauth (fun () ->
call_extauth_plugin_nomutex ~__context ~host ~fn ~args
)
(* this is the generic plugin call available to xapi users *)
let call_plugin ~__context ~host ~plugin ~fn ~args =
if plugin = extauth_hook_script_name
then call_extauth_plugin ~__context ~host ~fn ~args
else Xapi_plugins.call_plugin (Context.get_session_id __context) plugin fn args
let sync_data ~__context ~host =
Xapi_sync.sync_host __context host (* Nb, no attempt to wrap exceptions yet *)
let backup_rrds ~__context ~host ~delay =
Xapi_periodic_scheduler.add_to_queue "RRD backup" Xapi_periodic_scheduler.OneShot
delay (fun _ ->
log_and_ignore_exn (Rrdd.backup_rrds ~save_stats_locally:(Pool_role.is_master ()))
)
let get_servertime ~__context ~host =
Date.of_float (Unix.gettimeofday ())
let get_server_localtime ~__context ~host =
let gmt_time= Unix.gettimeofday () in
let local_time = Unix.localtime gmt_time in
Date.of_string
(
Printf.sprintf "%04d%02d%02dT%02d:%02d:%02d"
(local_time.Unix.tm_year+1900)
(local_time.Unix.tm_mon+1)
local_time.Unix.tm_mday
local_time.Unix.tm_hour
local_time.Unix.tm_min
local_time.Unix.tm_sec
)
let enable_binary_storage ~__context ~host =
Unixext.mkdir_safe Xapi_globs.xapi_blob_location 0o700;
Db.Host.remove_from_other_config ~__context ~self:host ~key:Xapi_globs.host_no_local_storage
let disable_binary_storage ~__context ~host =
ignore(Helpers.get_process_output (Printf.sprintf "/bin/rm -rf %s" Xapi_globs.xapi_blob_location));
Db.Host.remove_from_other_config ~__context ~self:host ~key:Xapi_globs.host_no_local_storage;
Db.Host.add_to_other_config ~__context ~self:host ~key:Xapi_globs.host_no_local_storage ~value:"true"
(* Dummy implementation for a deprecated API method. *)
let get_uncooperative_resident_VMs ~__context ~self = []
(* Dummy implementation for a deprecated API method. *)
let get_uncooperative_domains ~__context ~self = []
let certificate_install ~__context ~host ~name ~cert =
Certificates.host_install true name cert
let certificate_uninstall ~__context ~host ~name =
Certificates.host_uninstall true name
let certificate_list ~__context ~host =
Certificates.local_list true
let crl_install ~__context ~host ~name ~crl =
Certificates.host_install false name crl
let crl_uninstall ~__context ~host ~name =
Certificates.host_uninstall false name
let crl_list ~__context ~host =
Certificates.local_list false
let certificate_sync ~__context ~host =
Certificates.local_sync()
let get_server_certificate ~__context ~host =
Certificates.get_server_certificate()
(* CA-24856: detect non-homogeneous external-authentication config in pool *)
let detect_nonhomogeneous_external_auth_in_host ~__context ~host =
Helpers.call_api_functions ~__context (fun rpc session_id ->
let pool = List.hd (Client.Client.Pool.get_all rpc session_id) in
let master = Client.Client.Pool.get_master rpc session_id pool in
let master_rec = Client.Client.Host.get_record rpc session_id master in
let host_rec = Client.Client.Host.get_record rpc session_id host in
(* if this host being verified is the master, then we need to verify homogeneity for all slaves in the pool *)
if (host_rec.API.host_uuid = master_rec.API.host_uuid)
then
Client.Client.Pool.detect_nonhomogeneous_external_auth rpc session_id pool
else (* this host is a slave, let's check if it is homogeneous to the master *)
let master_external_auth_type = master_rec.API.host_external_auth_type in
let master_external_auth_service_name = master_rec.API.host_external_auth_service_name in
let host_external_auth_type = host_rec.API.host_external_auth_type in
let host_external_auth_service_name = host_rec.API.host_external_auth_service_name in
if (host_external_auth_type <> master_external_auth_type
||
host_external_auth_service_name <> master_external_auth_service_name
) then begin
(* ... this slave has non-homogeneous external-authentication data *)
debug "Detected non-homogeneous external authentication in host %s: host_auth_type=%s, host_service_name=%s, master_auth_type=%s, master_service_name=%s"
(Ref.string_of host) host_external_auth_type host_external_auth_service_name
master_external_auth_type master_external_auth_service_name;
(* raise alert about this non-homogeneous slave in the pool *)
let host_uuid = host_rec.API.host_uuid in
let (name, priority) = Api_messages.auth_external_pool_non_homogeneous in
ignore(
Client.Client.Message.create ~rpc ~session_id ~name ~priority
~cls:`Host ~obj_uuid:host_uuid ~body:(
"host_external_auth_type="^host_external_auth_type^
", host_external_auth_service_name="^host_external_auth_service_name^
", master_external_auth_type="^master_external_auth_type^
", master_external_auth_service_name="^master_external_auth_service_name
)
)
end
)
(* CP-717: Enables external auth/directory service on a single host within the pool with specified config, *)
(* type and service_name. Fails if an auth/directory service is already enabled for this host (must disable first).*)
(*
* Each Host object will contain a string field, external_auth_type which will specify the type of the external auth/directory service.
o In the case of AD, this will contain the string "AD". (If we subsequently allow other types of external auth/directory service to be configured, e.g. LDAP, then new type strings will be defined accordingly)
o When no external authentication service is configured, this will contain the empty string
* Each Host object will contain a (string*string) Map field, external_auth_configuration. This field is provided so that a particular xapi authentiation module has the option of persistently storing any configuration parameters (represented as key/value pairs) within the agent database.
* Each Host object will contain a string field, external_auth_service_name, which contains sufficient information to uniquely identify and address the external authentication/directory service. (e.g. in the case of AD this would be a domain name)
*)
open Auth_signature
open Extauth
let enable_external_auth ~__context ~host ~config ~service_name ~auth_type =
(* CP-825: Serialize execution of host-enable-extauth and host-disable-extauth *)
(* we need to protect against concurrent access to the host.external_auth_type variable *)
Mutex.execute serialize_host_enable_disable_extauth (fun () ->
let host_name_label = Db.Host.get_name_label ~__context ~self:host in
let current_auth_type = Db.Host.get_external_auth_type ~__context ~self:host in
let current_service_name = Db.Host.get_external_auth_service_name ~__context ~self:host in
debug "current external_auth_type is %s" current_auth_type;
if (current_auth_type <> "") then
begin (* if auth_type is already defined, then we cannot set up a new one *)
let msg = (Printf.sprintf "external authentication %s service %s is already enabled" current_auth_type current_service_name) in
debug "Failed to enable external authentication type %s for service name %s in host %s: %s" auth_type service_name host_name_label msg;
raise (Api_errors.Server_error(Api_errors.auth_already_enabled, [current_auth_type;current_service_name]))
end
else if auth_type = "" then
begin (* we must error out here, because we never enable an _empty_ external auth_type *)
let msg = "" in
debug "Failed while enabling unknown external authentication type %s for service name %s in host %s" msg service_name host_name_label;
raise (Api_errors.Server_error(Api_errors.auth_unknown_type, [msg]))
end
else
begin (* if no auth_type is currently defined (it is an empty string), then we can set up a new one *)
(* we try to use the configuration to set up the new external authentication service *)
try
(* we persist as much set up configuration now as we can *)
Db.Host.set_external_auth_service_name ~__context ~self:host ~value:service_name;
(* the ext_auth.on_enable dispatcher called below will store the configuration params, and also *)
(* filter out any one-time credentials such as the administrator password, so we *)
(* should not call here 'host.set_external_auth_configuration ~config' *)
(* use the special 'named dispatcher' function to call an extauth plugin function even though we have *)
(* not yet set up the external_auth_type value that will enable generic access to the extauth plugin. *)
(Ext_auth.nd(auth_type)).on_enable config;
(* from this point on, we have successfully enabled the external authentication services. *)
(* Up to this point, we cannot call external auth functions via extauth's generic dispatcher d(). *)
Db.Host.set_external_auth_type ~__context ~self:host ~value:auth_type;
(* From this point on, anyone can call external auth functions via extauth.ml's generic dispatcher d(), which depends on the value of external_auth_type. *)
(* This enables all functions to the external authentication and directory service that xapi makes available to the user, *)
(* such as external login, subject id/info queries, group membership etc *)