CA-356901: Perform ldap query if winbind failed to resovle subject

ocaml/tests/test_extauth_plugin_ADwinbind.ml

@@ -112,6 +112,28 @@ let test_domainify_uname =
   |> List.map @@ fun (inp, exp) ->
      (Printf.sprintf "%s -> %s" inp exp, `Quick, check inp exp)
 
+let test_ldap_escape =
+  let open Extauth_plugin_ADwinbind.Ldap in
+  let check str exp () =
+    let msg = Printf.sprintf "%s -> %s" str exp in
+    let escaped = escape str in
+    Alcotest.(check string) msg exp escaped
+  in
+  let matrix =
+    [
+      ({|user|}, {|user|})
+    ; ({|(user)|}, {|\28user\29|})
+    ; ({|(user|}, {|\28user|})
+    ; ({|user)|}, {|user\29|})
+    ; ({|us\er)|}, {|us\5der\29|})
+    ; ({|user)1|}, {|user\291|})
+    ; ({|user*|}, {|user\2a|})
+    ]
+  in
+  matrix
+  |> List.map @@ fun (inp, exp) ->
+     (Printf.sprintf "%s -> %s" inp exp, `Quick, check inp exp)
+
 let test_parse_wbinfo_uid_info =
   let open Extauth_plugin_ADwinbind.Wbinfo in
   let string_of_result x =
@@ -424,6 +446,7 @@ let tests =
   ; ("ADwinbind:test_range", Range.tests)
   ; ("ADwinbind:test_parse_value_from_pbis", ParseValueFromPbis.tests)
   ; ("ADwinbind:test_domainify_uname", test_domainify_uname)
+  ; ("ADwinbind:test_ldap_escape", test_ldap_escape)
   ; ("ADwinbind:test_parse_wbinfo_uid_info", test_parse_wbinfo_uid_info)
   ; ("ADwinbind:test_parse_ldap_stdout", test_parse_ldap_stdout)
   ; ( "ADwinbind:test_wbinfo_exception_of_stderr"

ocaml/xapi/extauth_plugin_ADwinbind.ml

@@ -62,6 +62,14 @@ let domain_krb5_dir = Filename.concat Xapi_globs.samba_dir "lock/smb_krb5"
 
 let debug_level () = !Xapi_globs.winbind_debug_level |> string_of_int
 
+type domain_info = {
+    service_name: string
+  ; workgroup: string option
+        (* For upgrade case, the legacy db does not contain workgroup *)
+  ; netbios_name: string option
+        (* Persist netbios_name to support hostname change *)
+}
+
 let hd msg = function
   | [] ->
       error "%s" msg ;
@@ -81,7 +89,62 @@ let ntlm_auth uname passwd : (unit, exn) result =
     Ok ()
   with _ -> Error (auth_ex uname)
 
+let get_domain_info_from_db () =
+  Server_helpers.exec_with_new_task "retrieving external auth domain workgroup"
+  @@ fun __context ->
+  let host = Helpers.get_localhost ~__context in
+  let service_name =
+    Db.Host.get_external_auth_service_name ~__context ~self:host
+  in
+  let workgroup, netbios_name =
+    Db.Host.get_external_auth_configuration ~__context ~self:host
+    |> fun config ->
+    (List.assoc_opt "workgroup" config, List.assoc_opt "netbios_name" config)
+  in
+  {service_name; workgroup; netbios_name}
+
 module Ldap = struct
+  module Escape = struct
+    (*
+     * Escape characters according to
+     * https://docs.microsoft.com/en-gb/windows/win32/adsi/search-filter-syntax?redirectedfrom=MSDN#special-characters
+     * *)
+
+    let reg_star = {|*|} |> Re.str |> Re.compile
+
+    let reg_left_bracket = {|(|} |> Re.str |> Re.compile
+
+    let reg_right_bracket = {|)|} |> Re.str |> Re.compile
+
+    let reg_backward_slash = {|\|} |> Re.str |> Re.compile
+
+    let reg_null = "\000" |> Re.str |> Re.compile
+
+    let reg_slash = {|/|} |> Re.str |> Re.compile
+
+    let escape_map =
+      [
+        (* backward slash goes first as others will include backward slash*)
+        (reg_backward_slash, {|\5d|})
+      ; (reg_star, {|\2a|})
+      ; (reg_left_bracket, {|\28|})
+      ; (reg_right_bracket, {|\29|})
+      ; (reg_null, {|\00|})
+      ; (reg_slash, {|\2f|})
+      ]
+
+    let escape str =
+      List.fold_left
+        (fun acc element ->
+          let reg = fst element in
+          let value = snd element in
+          Re.replace_string reg ~by:value acc
+          )
+        str escape_map
+  end
+
+  let escape str = Escape.escape str
+
   type user = {
       name: string
     ; display_name: string
@@ -200,12 +263,15 @@ module Ldap = struct
       ; password_expired= logand user_account_control passw_expire_bit <> 0l
       }
 
-  let query_user sid domain_netbios kdc =
+  let env_of_krb5 domain_netbios =
     let domain_krb5_cfg =
       Filename.concat domain_krb5_dir
         (Printf.sprintf "krb5.conf.%s" domain_netbios)
     in
-    let env = [|Printf.sprintf "KRB5_CONFIG=%s" domain_krb5_cfg|] in
+    [|Printf.sprintf "KRB5_CONFIG=%s" domain_krb5_cfg|]
+
+  let query_user sid domain_netbios kdc =
+    let env = env_of_krb5 domain_netbios in
     let* stdout =
       try
         (* Query KDC instead of use domain here
@@ -227,9 +293,40 @@ module Ldap = struct
             args
         in
         Ok stdout
-      with _ -> Error (generic_ex "ldap query failed")
+      with _ -> Error (generic_ex "ldap query user info from sid failed")
     in
     parse_user stdout <!> generic_ex "%s"
+
+  let query_sid ~name ~kdc ~domain_netbios =
+    let key = "objectSid" in
+    let env = env_of_krb5 domain_netbios in
+    let name = escape name in
+    (* Escape name to avoid injection detection *)
+    let query = Printf.sprintf "(|(sAMAccountName=%s)(name=%s))" name name in
+    let args =
+      [
+        "ads"
+      ; "search"
+      ; "-d"
+      ; debug_level ()
+      ; "--server"
+      ; kdc
+      ; "--machine-pass"
+      ; query
+      ; key
+      ]
+    in
+    try
+      Helpers.call_script ~env !Xapi_globs.net_cmd args
+      |> 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)
+    | Not_found ->
+        Error (generic_ex "%s not found in ldap result" key)
+    | _ ->
+        Error (generic_ex "Failed to lookup sid from username %s" name)
 end
 
 type domain_name_type = Name | NetbiosName
@@ -345,6 +442,25 @@ module Wbinfo = struct
     | _ ->
         Error (generic_ex "Invalid domain user name %s" uname)
 
+  let domain_and_user_of_uname uname =
+    let open Astring.String in
+    match String.split_on_char '\\' uname with
+    | [netbios; user] ->
+        let* domain =
+          domain_name_of ~target_name_type:Name ~from_name:netbios
+        in
+        Ok (domain, user)
+    | _ -> (
+      match String.split_on_char '@' uname with
+      | [user; domain] ->
+          Ok (domain, user)
+      | _ ->
+          if is_infix ~affix:"@" uname || is_infix ~affix:{|\|} uname then
+            Error (generic_ex "Invalid domain user name %s" uname)
+          else
+            Ok ((get_domain_info_from_db ()).service_name, uname)
+    )
+
   let all_domain_netbios () =
     (*
      * List all domains (trusted and own domain)
@@ -445,14 +561,6 @@ module Wbinfo = struct
     parse_uid_info stdout <!> fun () -> parsing_ex args
 end
 
-type domain_info = {
-    service_name: string
-  ; workgroup: string option
-        (* For upgrade case, the legacy db does not contain workgroup *)
-  ; netbios_name: string option
-        (* Persist netbios_name to support hostname change *)
-}
-
 module Migrate_from_pbis = struct
   (* upgrade-pbis-to-winbind handles most of the migration from PBIS database
    * to winbind database
@@ -532,21 +640,6 @@ module Migrate_from_pbis = struct
     netbios_name
 end
 
-let get_domain_info_from_db () =
-  (fun __context ->
-    let host = Helpers.get_localhost ~__context in
-    let service_name =
-      Db.Host.get_external_auth_service_name ~__context ~self:host
-    in
-    let workgroup, netbios_name =
-      Db.Host.get_external_auth_configuration ~__context ~self:host |> fun l ->
-      (List.assoc_opt "workgroup" l, List.assoc_opt "netbios_name" l)
-    in
-    {service_name; workgroup; netbios_name}
-    )
-  |> Server_helpers.exec_with_new_task
-       "retrieving external auth domain workgroup"
-
 let kdcs_of_domain domain =
   try
     Helpers.call_script ~log_output:On_failure net_cmd
@@ -625,11 +718,9 @@ let from_config ~name ~err_msg ~config_params =
 let all_number_re = Re.Perl.re {|^\d+$|} |> Re.Perl.compile
 
 let get_localhost_name () =
-  (fun __context ->
-    Helpers.get_localhost ~__context |> fun host ->
-    Db.Host.get_hostname ~__context ~self:host
-    )
-  |> Server_helpers.exec_with_new_task "retrieving hostname"
+  Server_helpers.exec_with_new_task "retrieving hostname" @@ fun __context ->
+  Helpers.get_localhost ~__context |> fun host ->
+  Db.Host.get_hostname ~__context ~self:host
 
 let assert_hostname_valid ~hostname =
   let all_numbers = Re.matches all_number_re hostname <> [] in
@@ -665,13 +756,12 @@ let persist_extauth_config ~domain ~user ~ou_conf ~workgroup ~netbios_name =
         ]
         @ ou_conf
   in
-  (fun __context ->
-    Helpers.get_localhost ~__context |> fun self ->
-    Db.Host.set_external_auth_configuration ~__context ~self ~value ;
-    Db.Host.get_name_label ~__context ~self
-    |> debug "update external_auth_configuration for host %s"
-    )
-  |> Server_helpers.exec_with_new_task "update external_auth_configuration"
+  Server_helpers.exec_with_new_task "update external_auth_configuration"
+  @@ fun __context ->
+  Helpers.get_localhost ~__context |> fun self ->
+  Db.Host.set_external_auth_configuration ~__context ~self ~value ;
+  Db.Host.get_name_label ~__context ~self
+  |> debug "update external_auth_configuration for host %s"
 
 let disable_machine_account ~service_name = function
   | Some u, Some p -> (
@@ -833,21 +923,19 @@ module ClosestKdc = struct
         Error e
 
   let update_db ~domain ~kdc =
-    (fun __context ->
-      let self = Helpers.get_localhost ~__context in
-      Db.Host.get_external_auth_configuration ~__context ~self |> fun value ->
-      (domain, kdc) :: List.remove_assoc domain value |> fun value ->
-      Db.Host.set_external_auth_configuration ~__context ~self ~value
-      )
-    |> Server_helpers.exec_with_new_task "update domain closest kdc"
+    Server_helpers.exec_with_new_task "update domain closest kdc"
+    @@ fun __context ->
+    let self = Helpers.get_localhost ~__context in
+    Db.Host.get_external_auth_configuration ~__context ~self |> fun value ->
+    (domain, kdc) :: List.remove_assoc domain value |> fun value ->
+    Db.Host.set_external_auth_configuration ~__context ~self ~value
 
   let from_db domain =
-    (fun __context ->
-      let self = Helpers.get_localhost ~__context in
-      Db.Host.get_external_auth_configuration ~__context ~self
-      |> List.assoc_opt domain
-      )
-    |> Server_helpers.exec_with_new_task "query domain closest kdc"
+    Server_helpers.exec_with_new_task "query domain closest kdc"
+    @@ fun __context ->
+    let self = Helpers.get_localhost ~__context in
+    Db.Host.get_external_auth_configuration ~__context ~self
+    |> List.assoc_opt domain
 
   let lookup domain =
     try
@@ -921,13 +1009,33 @@ let build_dns_hostname_option ~config_params =
   | _ ->
       []
 
+let closest_kdc_of_domain domain =
+  match ClosestKdc.from_db domain with
+  | Some kdc ->
+      kdc
+  | None ->
+      (* Just pick the first KDC in the list *)
+      kdc_of_domain domain
+
 module AuthADWinbind : Auth_signature.AUTH_MODULE = struct
   let get_subject_identifier' subject_name =
+    (* Called in the login path with a yet unauthenticated user *)
     let* domain =
       try Ok (get_domain_info_from_db ()).service_name with e -> Error e
     in
     let subject_name = domainify_uname ~domain subject_name in
-    Wbinfo.sid_of_name subject_name
+    match Wbinfo.sid_of_name subject_name with
+    | Ok sid ->
+        Ok sid
+    | Error e ->
+        debug "Failed to query sid from cache, error: %s, retry ldap"
+          (ExnHelper.string_of_exn e) ;
+        let* domain, user = Wbinfo.domain_and_user_of_uname subject_name in
+        let* domain_netbios =
+          Wbinfo.domain_name_of ~target_name_type:NetbiosName ~from_name:domain
+        in
+        let kdc = closest_kdc_of_domain domain in
+        Ldap.query_sid ~name:user ~kdc ~domain_netbios
 
   (* subject_id get_subject_identifier(string subject_name)
 
@@ -1004,14 +1112,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct
   let query_subject_information_user (uid : int) (sid : string) =
     let* {user_name; gecos; gid} = Wbinfo.uid_info_of_uid uid in
     let* domain_netbios, domain = Wbinfo.domain_of_uname user_name in
-    let closest_kdc =
-      match ClosestKdc.from_db domain with
-      | Some kdc ->
-          kdc
-      | None ->
-          (* Just pick the first KDC in the list *)
-          kdc_of_domain domain
-    in
+    let closest_kdc = closest_kdc_of_domain domain in
     let* {
            name
          ; upn

ocaml/xapi/extauth_plugin_ADwinbind.mli

@@ -61,6 +61,8 @@ module Ldap : sig
   val string_of_user : user -> string
 
   val parse_user : string -> (user, string) result
+
+  val escape : string -> string
 end
 
 module Migrate_from_pbis : sig