@@ -29,7 +29,7 @@ let ( let* ) = Result.bind
2929
3030let ( <!> ) x f = Rresult.R. reword_error f x
3131
32- let (>> | ) = Rresult. (>> | )
32+ let ( >> | ) = Rresult. ( >> | )
3333
3434let maybe_raise (x : ('a, exn) result ) : 'a =
3535 match x with Ok x -> x | Error e -> raise e
@@ -68,8 +68,7 @@ let ntlm_auth uname passwd : (unit, exn) result =
6868 ! Xapi_globs. ntlm_auth_cmd args
6969 in
7070 Ok ()
71- with _ ->
72- Error (auth_ex uname)
71+ with _ -> Error (auth_ex uname)
7372
7473module Ldap = struct
7574 type user = {
@@ -180,7 +179,6 @@ module Ldap = struct
180179 ; password_expired= logand user_account_control passw_expire_bit <> 0l
181180 }
182181
183-
184182 let net_ads (sid : string ) : (string, exn) result =
185183 try
186184 let args = [" ads" ; " sid" ; " -d" ; debug_level; " --machine-pass" ; sid] in
@@ -204,7 +202,6 @@ module Ldap = struct
204202end
205203
206204module Wbinfo = struct
207-
208205 let exception_of_stderr =
209206 let open Auth_signature in
210207 let regex = Re.Perl. (compile (re {|.* (WBC_ERR_ [A - Z_ ]* ).*| })) in
@@ -241,8 +238,8 @@ module Wbinfo = struct
241238 let generic_err () =
242239 Error (generic_ex " 'wbinfo %s' failed" (String. concat " " args))
243240 in
241+ (* we trust wbinfo will not print any sensitive info on failure *)
244242 try
245- (* we trust wbinfo will not print any sensitive info on failure *)
246243 let stdout = Helpers. call_script ~log_output: On_failure wb_cmd args in
247244 Ok stdout
248245 with
@@ -297,8 +294,7 @@ module Wbinfo = struct
297294 | [|_; name; _|] ->
298295 Some (Other name)
299296 | _ ->
300- None
301- )
297+ None )
302298 in
303299 fun sid ->
304300 let args = [" --sid-to-name" ; sid] in
@@ -348,7 +344,7 @@ module Wbinfo = struct
348344 | _ ->
349345 Error ()
350346
351- let uid_info_of_uid (uid : int ) =
347+ let uid_info_of_uid (uid : int ) =
352348 let args = [" --uid-info" ; string_of_int uid] in
353349 let * stdout = call_wbinfo args in
354350 parse_uid_info stdout < ! > fun () -> parsing_ex args
@@ -384,10 +380,27 @@ let query_domain_workgroup ~domain ~db_workgroup =
384380 let err_msg =
385381 Printf. sprintf " Failed to look up domain %s workgroup" domain
386382 in
383+ let hd msg = function
384+ | [] ->
385+ error " %s" msg ;
386+ raise (Auth_service_error (E_LOOKUP , msg))
387+ | h :: _ ->
388+ h
389+ in
387390 try
391+ let kdc =
392+ Helpers. call_script ~log_output: On_failure net_cmd
393+ [" lookup" ; " kdc" ; domain; " -d" ; debug_level]
394+ (* Result like 10.71.212.25:88\n10.62.1.25:88\n*)
395+ |> String. split_on_char '\n'
396+ |> hd " lookup kdc return invalid result"
397+ |> String. split_on_char ':'
398+ |> hd " kdc has invalid address"
399+ in
400+
388401 let lines =
389402 Helpers. call_script ~log_output: On_failure net_cmd
390- [" ads" ; " lookup" ; " -S" ; domain ; " -d" ; debug_level]
403+ [" ads" ; " lookup" ; " -S" ; kdc ; " -d" ; debug_level]
391404 in
392405 match Xapi_cmd_result. of_output_opt ~sep: ':' ~key ~lines with
393406 | Some v ->
@@ -484,17 +497,20 @@ let persist_extauth_config ~domain ~user ~ou_conf ~workgroup =
484497 |> debug " update external_auth_configuration for host %s" )
485498 |> Server_helpers. exec_with_new_task " update external_auth_configuration"
486499
487- let clean_machine_account ~service_name = function
500+ let disable_machine_account ~service_name = function
488501 | Some u , Some p -> (
489- (* Clean machine account in DC *)
502+ (* Disable machine account in DC *)
490503 let env = [|Printf. sprintf " PASSWD=%s" p|] in
491- let args = [" ads" ; " leave" ; " -U" ; u; " -d" ; debug_level] in
504+ let args =
505+ [" ads" ; " leave" ; " -U" ; u; " --keep-account" ; " -d" ; debug_level]
506+ in
492507 try
493508 Helpers. call_script ~env net_cmd args |> ignore ;
494- debug " Succeed to clean the machine account for domain %s" service_name
509+ debug " Succeed to disable the machine account for domain %s"
510+ service_name
495511 with _ ->
496512 let msg =
497- Printf. sprintf " Failed to clean the machine account for domain %s"
513+ Printf. sprintf " Failed to disable the machine account for domain %s"
498514 service_name
499515 in
500516 debug " %s" msg ;
@@ -614,37 +630,39 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct
614630 Raises auth_failure if authentication is not successful
615631 *)
616632
617- let authenticate_username_password uname password =
618- (* the ntlm_auth binary expects the username to be in either SAM or UPN format.
619- * we use wbinfo to try to convert the provided [uname] into said format.
620- * as a last ditch attempt, we try to auth with the provided [uname]
621- *
622- * see CA-346287 for more information *)
623- let orig_uname = uname in
624- (let * sid =
625- (* we change the exception, since otherwise we get an (incorrect) error
626- * message saying that credentials are correct, but we are not authorized *)
627- get_subject_identifier' uname < ! > function
628- | Auth_failure _ as e ->
629- e
630- | Auth_service_error (E_GENERIC, msg ) ->
631- Auth_failure msg
632- | e ->
633- D. error " authenticate_username_password:ex: %s" (Printexc. to_string e) ;
634- Auth_failure
635- (Printf. sprintf " couldn't get SID from username='%s'" uname)
636- in
637- let * () =
638- match Wbinfo. name_of_sid sid >> | Wbinfo. string_of_name with
639- | Error e ->
640- D. warn " authenticate_username_password: trying original uname. ex: %s"
641- (Printexc. to_string e) ;
642- ntlm_auth orig_uname password
643- | Ok uname ->
644- ntlm_auth orig_uname password
645- in
646- Ok sid)
647- |> maybe_raise
633+ let authenticate_username_password uname password =
634+ (* the ntlm_auth binary expects the username to be in either SAM or UPN format.
635+ * we use wbinfo to try to convert the provided [uname] into said format.
636+ * as a last ditch attempt, we try to auth with the provided [uname]
637+ *
638+ * see CA-346287 for more information *)
639+ let orig_uname = uname in
640+ (let * sid =
641+ (* we change the exception, since otherwise we get an (incorrect) error
642+ * message saying that credentials are correct, but we are not authorized *)
643+ get_subject_identifier' uname < ! > function
644+ | Auth_failure _ as e ->
645+ e
646+ | Auth_service_error (E_GENERIC, msg ) ->
647+ Auth_failure msg
648+ | e ->
649+ D. error " authenticate_username_password:ex: %s"
650+ (Printexc. to_string e) ;
651+ Auth_failure
652+ (Printf. sprintf " couldn't get SID from username='%s'" uname)
653+ in
654+ let * () =
655+ match Wbinfo. name_of_sid sid >> | Wbinfo. string_of_name with
656+ | Error e ->
657+ D. warn
658+ " authenticate_username_password: trying original uname. ex: %s"
659+ (Printexc. to_string e) ;
660+ ntlm_auth orig_uname password
661+ | Ok uname ->
662+ ntlm_auth orig_uname password
663+ in
664+ Ok sid)
665+ |> maybe_raise
648666
649667 (* subject_id Authenticate_ticket(string ticket)
650668
@@ -814,7 +832,7 @@ let authenticate_username_password uname password =
814832 let user = List. assoc_opt " user" config_params in
815833 let pass = List. assoc_opt " pass" config_params in
816834 let {service_name; _} = get_domain_info_from_db () in
817- clean_machine_account ~service_name (user, pass) ;
835+ disable_machine_account ~service_name (user, pass) ;
818836 (* Clean local resources *)
819837 clean_local_resources () ;
820838 (* Clean extauth config *)
0 commit comments