CP-311257: Raise proper error code (#6963)

Author: liulinC

ocaml/idl/datamodel_errors.ml

@@ -734,7 +734,9 @@ let _ =
   error Api_errors.auth_unknown_type ["type"]
     ~doc:"Unknown type of external authentication." () ;
   error Api_errors.auth_is_disabled []
-    ~doc:"External authentication is disabled, unable to resolve subject name."
+    ~doc:"External authentication is disabled" () ;
+  error Api_errors.auth_invalid_certs ["message"]
+    ~doc:"The certificates are invalid to setup TLS connection to Windows AD."
     () ;
   error Api_errors.auth_enable_failed ["message"]
     ~doc:"The host failed to enable external authentication." () ;
@@ -750,6 +752,8 @@ let _ =
     ~doc:"The host failed to enable external authentication." () ;
   error Api_errors.auth_enable_failed_invalid_account ["message"]
     ~doc:"The host failed to enable external authentication." () ;
+  error Api_errors.auth_enable_failed_invalid_certs ["message"]
+    ~doc:"The host failed to enable external authentication." () ;
   error Api_errors.auth_disable_failed ["message"]
     ~doc:"The host failed to disable external authentication." () ;
   error Api_errors.auth_disable_failed_wrong_credentials ["message"]
@@ -839,7 +843,9 @@ let _ =
     ~doc:"The pool failed to enable external authentication." () ;
   error Api_errors.pool_auth_enable_failed_invalid_account ["host"; "message"]
     ~doc:"The pool failed to enable external authentication." () ;
-  error Api_errors.pool_auth_set_ldaps_failed ["host"; "message"]
+  error Api_errors.pool_auth_enable_failed_invalid_certs ["host"; "message"]
+    ~doc:"The pool failed to enable external authentication." () ;
+  error Api_errors.auth_set_ldaps_failed ["host"; "message"]
     ~doc:"The pool failed to set LDAPS configuration." () ;
   error Api_errors.pool_auth_disable_failed ["host"; "message"]
     ~doc:

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml

@@ -100,6 +100,16 @@ module List = struct
     in
     loop [] l
 
+  let try_map_any f l =
+    let rec loop errs = function
+      | [] ->
+          Error (List.rev errs)
+      | x :: xs -> (
+        match f x with Ok _ as ok -> ok | Error e -> loop (e :: errs) xs
+      )
+    in
+    loop [] l
+
   let take n list =
     let rec loop i acc = function
       | x :: xs when i < n ->

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli

@@ -50,6 +50,11 @@ module List : sig
       the [Ok] results, and the first [Error] result encountered, if it is
       encountered. *)
 
+  val try_map_any : ('a -> ('b, 'c) result) -> 'a list -> ('b, 'c list) result
+  (** [try_map_any f l] applies [f] to elements of [l] in turn. Returns the
+      first [Ok] result encountered or, if all elements produce errors, returns
+      all the [Error] results in a list. *)
+
   val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
   (** [rev_map f l] gives the same result as {!Stdlib.List.rev}[ (]
       {!Stdlib.List.mapi}[ f l)], but is tail-recursive and more efficient. *)

ocaml/tests/test_extauth_plugin_ADwinbind.ml

@@ -90,6 +90,8 @@ module Errtag = Generic.MakeStateless (struct
           "E_INVALID_OU"
       | E_INVALID_ACCOUNT ->
           "E_INVALID_ACCOUNT"
+      | E_INVALID_CERTS ->
+          "E_INVALID_CERTS"
   end
 
   let transform = Extauth_plugin_ADwinbind.tag_from_err_msg

ocaml/xapi-consts/api_errors.ml

@@ -1023,6 +1023,8 @@ let auth_unknown_type = add_error "AUTH_UNKNOWN_TYPE"
 
 let auth_is_disabled = add_error "AUTH_IS_DISABLED"
 
+let auth_invalid_certs = add_error "AUTH_INVALID_CERTS"
+
 let auth_suffix_wrong_credentials = "_WRONG_CREDENTIALS"
 
 let auth_suffix_permission_denied = "_PERMISSION_DENIED"
@@ -1035,6 +1037,8 @@ let auth_suffix_invalid_ou = "_INVALID_OU"
 
 let auth_suffix_invalid_account = "_INVALID_ACCOUNT"
 
+let auth_suffix_invalid_certs = "_INVALID_CERTS"
+
 let auth_enable_failed = add_error "AUTH_ENABLE_FAILED"
 
 let auth_enable_failed_wrong_credentials =
@@ -1055,6 +1059,9 @@ let auth_enable_failed_invalid_ou =
 let auth_enable_failed_invalid_account =
   add_error $ auth_enable_failed ^ auth_suffix_invalid_account
 
+let auth_enable_failed_invalid_certs =
+  add_error $ auth_enable_failed ^ auth_suffix_invalid_certs
+
 let auth_disable_failed = add_error "AUTH_DISABLE_FAILED"
 
 let auth_disable_failed_wrong_credentials =
@@ -1087,10 +1094,13 @@ let pool_auth_enable_failed_invalid_ou =
 let pool_auth_enable_failed_invalid_account =
   add_error $ pool_auth_enable_failed ^ auth_suffix_invalid_account
 
+let pool_auth_enable_failed_invalid_certs =
+  add_error $ pool_auth_enable_failed ^ auth_suffix_invalid_certs
+
 let pool_auth_enable_failed_duplicate_hostname =
   add_error $ pool_auth_enable_failed ^ "_DUPLICATE_HOSTNAME"
 
-let pool_auth_set_ldaps_failed = add_error "POOL_AUTH_SET_LDAPS_FAILED"
+let auth_set_ldaps_failed = add_error "AUTH_SET_LDAPS_FAILED"
 
 let pool_auth_disable_failed =
   add_error $ pool_auth_prefix ^ auth_disable_failed

ocaml/xapi/auth_signature.ml

@@ -31,6 +31,7 @@ type auth_service_error_tag =
   | E_UNAVAILABLE
   | E_INVALID_OU
   | E_INVALID_ACCOUNT
+  | E_INVALID_CERTS
 
 exception Auth_service_error of auth_service_error_tag * string
 
@@ -52,6 +53,8 @@ let suffix_of_tag errtag =
       Api_errors.auth_suffix_invalid_ou
   | E_INVALID_ACCOUNT ->
       Api_errors.auth_suffix_invalid_account
+  | E_INVALID_CERTS ->
+      Api_errors.auth_suffix_invalid_certs
 
 (* required fields in subject.other_config *)
 let subject_information_field_subject_name = "subject-name"

ocaml/xapi/extauth.ml

@@ -203,6 +203,8 @@ let call_with_exception_handler fn =
       raise (Api_errors.Server_error (Api_errors.auth_unknown_type, [msg]))
   | Not_found | Auth_signature.Subject_cannot_be_resolved ->
       raise (Api_errors.Server_error (Api_errors.subject_cannot_be_resolved, []))
+  | Auth_signature.Auth_service_error (E_INVALID_CERTS, msg) ->
+      raise (Api_errors.Server_error (Api_errors.auth_invalid_certs, [msg]))
   | Auth_signature.Auth_service_error (_, msg) ->
       raise (Api_errors.Server_error (Api_errors.auth_service_error, [msg]))
   | e ->

ocaml/xapi/extauth_plugin_ADwinbind.ml

@@ -22,6 +22,7 @@ end)
 open D
 open Xapi_stdext_std.Xstringext
 open Auth_signature
+module Listext = Xapi_stdext_std.Listext
 module Scheduler = Xapi_stdext_threads_scheduler.Scheduler
 
 let finally = Xapi_stdext_pervasives.Pervasiveext.finally
@@ -81,9 +82,13 @@ let debug_level () =
   |> string_of_int
 
 let err_msg_to_tag_map =
+  let open Auth_signature in
   [
-    ("not a properly formed account name", Auth_signature.E_INVALID_ACCOUNT)
-  ; ("bad username or authentication", Auth_signature.E_CREDENTIALS)
+    ("not a properly formed account name", E_INVALID_ACCOUNT)
+  ; ("bad username or authentication", E_CREDENTIALS)
+  ; ( "Windows cannot verify the digital signature for this file"
+    , E_INVALID_CERTS
+    )
     (* Some other errors *)
   ]
 
@@ -265,6 +270,12 @@ let tag_from_err_msg msg =
   | None ->
       Auth_signature.E_GENERIC
 
+let auth_ex_of_msg errmsg fmt =
+  let tag = tag_from_err_msg errmsg in
+  Printf.ksprintf
+    (fun msg -> Auth_signature.(Auth_service_error (tag, msg)))
+    fmt
+
 let update_extauth_configuration ~__context ~k ~v =
   let self = Helpers.get_localhost ~__context in
   Db.Host.get_external_auth_configuration ~__context ~self |> fun value ->
@@ -549,24 +560,25 @@ module Ldap = struct
       |> Xapi_cmd_result.of_output ~sep:':' ~key
       |> fun x -> Ok x
     with
-    | Forkhelpers.Spawn_internal_error (_, stdout, _) ->
-        Error (generic_ex "Ldap query sid failed: %s" stdout)
+    | Forkhelpers.Spawn_internal_error (err, out, _) ->
+        Error
+          (auth_ex_of_msg err "Failed to do ldap(s) query for %s %s" name out)
     | Not_found ->
         Error (generic_ex "%s not found in ldap result" key)
     | _ ->
         Error (generic_ex "Failed to lookup sid from username %s" name)
 
   let ping_domain domain =
-    match
-      kdcs_of_domain domain
-      |> List.find_opt (fun kdc ->
-          query_sid ~name:krbtgt ~kdc:(KDC.server kdc) |> Result.is_ok
+    kdcs_of_domain domain
+    |> Listext.List.try_map_any (fun kdc ->
+        query_sid ~name:krbtgt ~kdc:(KDC.server kdc)
+    )
+    |> Result.map_error (function
+      | e :: _ ->
+          e
+      | [] ->
+          generic_ex "Failed to ping domain %s" domain
       )
-    with
-    | Some _ ->
-        Ok ()
-    | None ->
-        Error (generic_ex "Failed to ping domain %s: all kdcs failed" domain)
 end
 
 module Wbinfo = struct
@@ -1161,24 +1173,22 @@ let set_ldaps ~__context ~ldaps ~force =
   if old_domain_info.ldaps = Some ldaps && not force then
     raise (generic_ex "ldaps is already %s" (string_of_bool ldaps)) ;
 
+  (* check certificate exists *)
   let new_domain_info = {old_domain_info with ldaps= Some ldaps} in
   (* Apply new configuration to winbind daemon for trial *)
   Winbind.configure ~__context ~domain_info:new_domain_info () ;
   (* Verify the new LDAP(S) setting works *)
   match Ldap.ping_domain new_domain_info.service_name with
-  | Ok () ->
+  | Ok _ ->
       (* Ping succeeded, persist the new domain_info *)
+      debug "%s ping domain succeed" __FUNCTION__ ;
       DomainInfo.to_db ~__context ~domain_info:(Some new_domain_info)
   | Error e ->
       (* Ping failed, restore the old configuration *)
       Winbind.configure ~__context ~domain_info:old_domain_info () ;
-      raise
-        (generic_ex
-           "ldap(s) verification failed for domain %s: %s, restored old \
-            configuration"
-           new_domain_info.service_name
-           (ExnHelper.string_of_exn e)
-        )
+      debug "%s ldap(s) verification failed, restored old configure"
+        __FUNCTION__ ;
+      raise e
 
 module RotateMachinePassword = struct
   let task_name = "Rotating machine password"

ocaml/xapi/xapi_host.ml

@@ -1981,16 +1981,18 @@ let disable_external_auth ~__context ~host ~config ~force =
     ~force ()
 
 (* Enable or disable LDAPS for external authentication on a host *)
-let external_auth_set_ldaps ~__context ~host:_ ~ldaps ~force =
-  let assert_can_set_ldaps () =
-    (* Host level check *)
-    let assert_certs () = () in
-    assert_certs ()
+let external_auth_set_ldaps ~__context ~host ~ldaps ~force =
+  let open Api_errors in
+  let auth_error_to_set_ldaps_error f =
+    try f ()
+    with Server_error (code, params) when code = auth_service_error ->
+      raise (Server_error (auth_set_ldaps_failed, Ref.string_of host :: params))
   in
 
   (* Just dispatch to the backend *)
   with_lock serialize_host_enable_disable_extauth @@ fun () ->
-  assert_can_set_ldaps () ;
+  auth_error_to_set_ldaps_error @@ fun () ->
+  Extauth.call_with_exception_handler @@ fun () ->
   (Ext_auth.d ()).set_ldaps ~__context ~ldaps ~force
 
 module Static_vdis_list = Xapi_database.Static_vdis_list

ocaml/xapi/xapi_pool.ml

@@ -3117,7 +3117,7 @@ let disable_external_auth ~__context ~pool:_ ~config =
       )
   )
 
-(* Set or unset ldaps for external authentication on all hosts in the pool *)
+(* Enable or disable LDAPS for external authentication on all hosts in the pool *)
 let external_auth_set_ldaps ~__context ~pool:_ ~ldaps ~force =
   let host = Helpers.get_master ~__context in
   let current_ldaps =
@@ -3126,46 +3126,19 @@ let external_auth_set_ldaps ~__context ~pool:_ ~ldaps ~force =
   in
 
   let hosts = Xapi_pool_helpers.get_master_slaves_list ~__context in
-  let assert_can_set_ldaps () =
-    (* Pool level check *)
-    let assert_ad_enabled () =
-      List.find_opt
-        (fun host -> not (Helpers.is_ad_enabled ~__context ~host))
-        hosts
-      |> Option.fold ~none:() ~some:(fun host ->
-          let host = Ref.string_of host in
-          raise Api_errors.(Server_error (auth_is_disabled, [host]))
-      )
-    in
-    assert_ad_enabled ()
-  in
   let set_ldap_on host =
     try
       call_fn_on_host ~__context
         (Client.Host.external_auth_set_ldaps ~ldaps ~force)
         host ;
       Ok host
-    with
-    | Api_errors.Server_error (_, [host_msg]) ->
-        let msg = Printf.sprintf "%s: %s" (Ref.string_of host) host_msg in
-        debug "%s failed to set ldaps for host %s" __FUNCTION__ msg ;
-        Error (host, msg)
-    | e ->
-        let msg =
-          Printf.sprintf "%s: %s" (Ref.string_of host)
-            (ExnHelper.string_of_exn e)
-        in
-        debug "%s failed to set ldaps for host %s" __FUNCTION__ msg ;
-        Error (host, msg)
+    with e ->
+      debug "%s failed to set ldaps for host %s: %s" __FUNCTION__
+        (Ref.string_of host)
+        (ExnHelper.string_of_exn e) ;
+      Error (host, e)
   in
   with_lock Xapi_globs.serialize_pool_enable_disable_extauth @@ fun () ->
-  assert_can_set_ldaps () ;
-  let raise_failed host msg =
-    raise
-      Api_errors.(
-        Server_error (pool_auth_set_ldaps_failed, [Ref.string_of host; msg])
-      )
-  in
   let revert host =
     try
       call_fn_on_host ~__context
@@ -3175,13 +3148,14 @@ let external_auth_set_ldaps ~__context ~pool:_ ~ldaps ~force =
       warn "Failed to revert ldaps on host %s: %s" (Ref.string_of host)
         (ExnHelper.string_of_exn e)
   in
+  (* Set ldaps to host and host will perform the necessary checks *)
   match Listext.List.try_map_collect set_ldap_on hosts with
   | Ok _ ->
       debug "%s succeed to set pool ldaps to %b" __FUNCTION__ ldaps
-  | Error (_, (host, msg)) when current_ldaps = ldaps ->
-      raise_failed host msg
-  | Error (hs, (host, msg)) ->
-      List.iter revert hs ; raise_failed host msg
+  | Error (_, (_, e)) when current_ldaps = ldaps ->
+      raise e
+  | Error (hs, (_, e)) ->
+      List.iter revert hs ; raise e
 
 (* CA-24856: detect non-homogeneous external-authentication config in pool *)
 let detect_nonhomogeneous_external_auth_in_pool ~__context =