diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index 0276206f1c0..dfc10dccb15 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -8,6 +8,7 @@ (libraries astring base64 + ipaddr mtime mtime.clock.os rpclib.core diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index d5103dfe604..65c54292c70 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -747,3 +747,54 @@ let read_chunked_encoding _req bio = Http.Item (chunk, next) in next () + +(* Helpers to determine the client of a call *) + +type protocol = Https | Http + +let string_of_protocol = function Https -> "HTTPS" | Http -> "HTTP" + +type client = protocol * Ipaddr.t + +let clean_addr_of_string ip = + (* in the IPv4 case, users should see 127.0.0.1 rather than ::ffff:127.0.0.1 *) + let ipv4_affix = "::ffff:" in + ( if Astring.String.is_prefix ~affix:ipv4_affix ip then + Astring.String.drop ~max:(String.length ipv4_affix) ip + else + ip + ) + |> Ipaddr.of_string + |> Stdlib.Result.to_option + +let https_client_of_req req = + (* this relies on 'protocol = proxy' in Xapi_stunnel_server *) + let stunnel_proxy = + List.assoc_opt "STUNNEL_PROXY" req.Http.Request.additional_headers + in + Option.bind stunnel_proxy (fun proxy -> + try + Scanf.sscanf proxy "TCP6 %s %s %d %d" (fun client _ _ _ -> client) + |> clean_addr_of_string + with _ -> + error "Failed to parse STUNNEL_PROXY='%s'" proxy ; + None + ) + +let client_of_req_and_fd req fd = + match https_client_of_req req with + | Some client -> + Some (Https, client) + | None -> ( + match Unix.getpeername fd with + | Unix.ADDR_INET (addr, _) -> + addr + |> Unix.string_of_inet_addr + |> clean_addr_of_string + |> Option.map (fun ip -> (Http, ip)) + | Unix.ADDR_UNIX _ | (exception _) -> + None + ) + +let string_of_client (protocol, ip) = + Printf.sprintf "%s %s" (string_of_protocol protocol) (Ipaddr.to_string ip) diff --git a/ocaml/libs/http-lib/http_svr.mli b/ocaml/libs/http-lib/http_svr.mli index 8b12ed2449a..d85ad28a2ec 100644 --- a/ocaml/libs/http-lib/http_svr.mli +++ b/ocaml/libs/http-lib/http_svr.mli @@ -131,3 +131,15 @@ val respond_to_options : Http.Request.t -> Unix.file_descr -> unit val headers : Unix.file_descr -> string list -> unit val read_body : ?limit:int -> Http.Request.t -> Buf_io.t -> string + +(* Helpers to determine the client of a call *) + +type protocol = Https | Http + +type client = protocol * Ipaddr.t + +val https_client_of_req : Http.Request.t -> Ipaddr.t option + +val client_of_req_and_fd : Http.Request.t -> Unix.file_descr -> client option + +val string_of_client : client -> string diff --git a/ocaml/tests/test_context.ml b/ocaml/tests/test_context.ml index ffc876f3904..6ad13fd89e7 100644 --- a/ocaml/tests/test_context.ml +++ b/ocaml/tests/test_context.ml @@ -16,7 +16,10 @@ let test_get_client_ip () = ] |> List.iter (fun (ip, exp) -> let client_ip = - proxy_string ip |> make_rq |> Context._client_of_rq |> Option.get + proxy_string ip + |> make_rq + |> Http_svr.https_client_of_req + |> Option.get in Alcotest.(check string) "original ip string preserved" exp diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index e4495dff745..feaf9559d93 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -35,10 +35,6 @@ let string_of_origin = function | Internal -> "Internal" -type http_t = Https | Http - -let string_of_http_t = function Https -> "HTTPS" | Http -> "HTTP" - (** A Context is used to represent every API invocation. It may be extended to include extra data without changing all the autogenerated signatures *) type t = { @@ -49,7 +45,7 @@ type t = { ; database: Db_ref.t ; dbg: string ; mutable tracing: Tracing.Span.t option - ; client: (http_t * Ipaddr.t) option + ; client: Http_svr.client option ; mutable test_rpc: (Rpc.call -> Rpc.response) option ; mutable test_clusterd_rpc: (Rpc.call -> Rpc.response) option } @@ -208,49 +204,11 @@ let trackid ?(with_brackets = false) ?(prefix = "") __context = (* CP-982: create tracking id in log files to link username to actions *) trackid_of_session ~with_brackets ~prefix __context.session_id -let _clean_addr_of_string ip = - (* in the IPv4 case, users should see 127.0.0.1 rather than ::ffff:127.0.0.1 *) - let ipv4_affix = "::ffff:" in - ( if Astring.String.is_prefix ~affix:ipv4_affix ip then - Astring.String.drop ~max:(String.length ipv4_affix) ip - else - ip - ) - |> Ipaddr.of_string - |> Stdlib.Result.to_option - -let _client_of_rq rq = - let stunnel_proxy = - List.assoc_opt "STUNNEL_PROXY" rq.Http.Request.additional_headers - in - Option.bind stunnel_proxy (fun proxy -> - try - Scanf.sscanf proxy "TCP6 %s %s %d %d" (fun client _ _ _ -> client) - |> _clean_addr_of_string - with _ -> - R.error "Failed to parse STUNNEL_PROXY='%s'" proxy ; - None - ) - let _client_of_origin = function | Internal -> None - | Http (rq, fd) -> ( - match _client_of_rq rq with - | Some client -> - (* this relies on 'protocol = proxy' in Xapi_stunnel_server *) - Some (Https, client) - | None -> ( - match Unix.getpeername fd with - | Unix.ADDR_INET (addr, _) -> - addr - |> Unix.string_of_inet_addr - |> _clean_addr_of_string - |> Option.map (fun ip -> (Http, ip)) - | Unix.ADDR_UNIX _ | (exception _) -> - None - ) - ) + | Http (req, fd) -> + Http_svr.client_of_req_and_fd req fd let make_dbg http_other_config task_name task_id = if List.mem_assoc "dbg" http_other_config then @@ -444,11 +402,7 @@ let set_test_clusterd_rpc context rpc = context.test_clusterd_rpc <- Some rpc let get_test_clusterd_rpc context = context.test_clusterd_rpc -let get_client context = - context.client - |> Option.map (fun (http, ip) -> - Printf.sprintf "%s %s" (string_of_http_t http) (Ipaddr.to_string ip) - ) +let get_client context = context.client |> Option.map Http_svr.string_of_client let get_client_ip context = context.client |> Option.map (fun (_, ip) -> Ipaddr.to_string ip) diff --git a/ocaml/xapi/context.mli b/ocaml/xapi/context.mli index 06c0d70535d..3f2b2c5dcf9 100644 --- a/ocaml/xapi/context.mli +++ b/ocaml/xapi/context.mli @@ -96,8 +96,6 @@ val destroy : t -> unit (** {6 Auxiliary functions } *) -val _client_of_rq : Http.Request.t -> Ipaddr.t option - val is_unix_socket : Unix.file_descr -> bool (** [is_unix_socket fd] *) diff --git a/ocaml/xapi/fileserver.ml b/ocaml/xapi/fileserver.ml index 6206ab49981..1c4cf9520e3 100644 --- a/ocaml/xapi/fileserver.ml +++ b/ocaml/xapi/fileserver.ml @@ -80,7 +80,7 @@ let response_file s file_path = Http_svr.response_file ~mime_content_type ~hsts_time s file_path let is_external_http req s = - (not (Context.is_unix_socket s)) && Context._client_of_rq req = None + (not (Context.is_unix_socket s)) && Http_svr.https_client_of_req req = None let access_forbidden req s = (* Reject external non-TLS requests (depending on config) *) diff --git a/ocaml/xapi/xapi_http.ml b/ocaml/xapi/xapi_http.ml index 1750a9e4317..13738ff292a 100644 --- a/ocaml/xapi/xapi_http.ml +++ b/ocaml/xapi/xapi_http.ml @@ -159,10 +159,19 @@ let assert_credentials_ok realm ?(http_action = realm) ?(fn = Rbac.nofn) else raise (Http.Unauthorised realm) | None, None, Some (Http.Basic (uname, pwd)) -> + debug "HTTP request with Basic auth user '%s' with User-Agent '%s'" + uname + (Option.value ~default:"unknown" req.Http.Request.user_agent) ; + let client = + Http_svr.( + client_of_req_and_fd req ic + |> Option.fold ~some:string_of_client ~none:"unknown" + ) + in let sess_creator () = Client.Session.login_with_password ~rpc:inet_rpc ~uname ~pwd ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:(client ^ " using Basic auth") in rbac_check_with_tmp_session sess_creator | None, None, Some (Http.UnknownAuth x) -> @@ -206,18 +215,27 @@ let with_context ?(dummy = false) label (req : Request.t) (s : Unix.file_descr) , true ) | None, None, Some (Http.Basic (uname, pwd)) -> ( - try - ( Client.Session.login_with_password ~rpc:inet_rpc ~uname ~pwd - ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent - , true - ) - with - | Api_errors.Server_error (code, _) - when code = Api_errors.session_authentication_failed - -> - raise (Http.Unauthorised label) - ) + debug "HTTP request with Basic auth user '%s' with User-Agent: '%s'" + uname + (Option.value ~default:"unknown" req.Http.Request.user_agent) ; + let client = + Http_svr.( + client_of_req_and_fd req s + |> Option.fold ~some:string_of_client ~none:"unknown" + ) + in + try + ( Client.Session.login_with_password ~rpc:inet_rpc ~uname ~pwd + ~version:Datamodel_common.api_version_string + ~originator:(client ^ " using Basic auth") + , true + ) + with + | Api_errors.Server_error (code, _) + when code = Api_errors.session_authentication_failed + -> + raise (Http.Unauthorised label) + ) | None, None, Some (Http.UnknownAuth x) -> raise (Failure (Printf.sprintf "Unknown authorization header: %s" x)) | None, None, None -> @@ -335,35 +353,54 @@ let add_handler (name, handler) = | Http_svr.BufIO callback -> Http_svr.BufIO (fun req ic context -> - try - if check_rbac then ( + let client = + Http_svr.( + client_of_req_and_fd req (Buf_io.fd_of ic) + |> Option.map string_of_client + ) + in + Debug.with_thread_associated ?client name + (fun () -> try - (* rbac checks *) - assert_credentials_ok name req - ~fn:(fun () -> callback req ic context) - (Buf_io.fd_of ic) - with e -> - debug "Leaving RBAC-handler in xapi_http after: %s" - (ExnHelper.string_of_exn e) ; - raise e - ) else (* no rbac checks *) - callback req ic context - with Api_errors.Server_error (name, params) as e -> - error "Unhandled Api_errors.Server_error(%s, [ %s ])" name - (String.concat "; " params) ; - raise (Http_svr.Generic_error (ExnHelper.string_of_exn e)) + if check_rbac then ( + try + (* rbac checks *) + assert_credentials_ok name req + ~fn:(fun () -> callback req ic context) + (Buf_io.fd_of ic) + with e -> + debug "Leaving RBAC-handler in xapi_http after: %s" + (ExnHelper.string_of_exn e) ; + raise e + ) else (* no rbac checks *) + callback req ic context + with Api_errors.Server_error (name, params) as e -> + error "Unhandled Api_errors.Server_error(%s, [ %s ])" name + (String.concat "; " params) ; + raise (Http_svr.Generic_error (ExnHelper.string_of_exn e)) + ) + () ) | Http_svr.FdIO callback -> Http_svr.FdIO (fun req ic context -> - try - if check_rbac then assert_credentials_ok name req ic ; - (* session and rbac checks *) - callback req ic context - with Api_errors.Server_error (name, params) as e -> - error "Unhandled Api_errors.Server_error(%s, [ %s ])" name - (String.concat "; " params) ; - raise (Http_svr.Generic_error (ExnHelper.string_of_exn e)) + let client = + Http_svr.( + client_of_req_and_fd req ic |> Option.map string_of_client + ) + in + Debug.with_thread_associated ?client name + (fun () -> + try + if check_rbac then assert_credentials_ok name req ic ; + (* session and rbac checks *) + callback req ic context + with Api_errors.Server_error (name, params) as e -> + error "Unhandled Api_errors.Server_error(%s, [ %s ])" name + (String.concat "; " params) ; + raise (Http_svr.Generic_error (ExnHelper.string_of_exn e)) + ) + () ) in match action with