Merge pull request #5159 from robhoes/http-client-logging

Improve logging at the beginning of HTTP handlers and for Basic auth

ocaml/libs/http-lib/dune

@@ -8,6 +8,7 @@
   (libraries
     astring
     base64
+    ipaddr
     mtime
     mtime.clock.os
     rpclib.core

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)

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

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

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)

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] *)
 

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) *)

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