From 1bbbe98e4b7a51b493e49408663cd6e657416061 Mon Sep 17 00:00:00 2001
From: Rob Hoes <rob.hoes@citrix.com>
Date: Fri, 8 Jul 2022 10:24:27 +0000
Subject: [PATCH 4/6] Receive timeout for TCP connections when first reading
 HTTP headers

When a connection to xapi's TCP socket is established, no authentication
has taken place until the HTTP request has been received. We need to
treat these connections with some more care until then.

To protect against unauthenticated clients holding connections open
without actually making any calls, a read timeout (10 seconds by
default) is introduced for every read from the socket until all headers
have been read. An HTTP 408 "request timeout" response is returned and
the connection broken if a timeout occurs.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 ocaml/libs/http-svr/http.ml      | 10 ++++++++-
 ocaml/libs/http-svr/http.mli     |  3 ++-
 ocaml/libs/http-svr/http_svr.ml  | 38 ++++++++++++++++++++------------
 ocaml/libs/http-svr/http_svr.mli |  3 ++-
 ocaml/libs/http-svr/http_test.ml |  2 +-
 ocaml/xapi/xapi_globs.ml         |  4 ++++
 ocaml/xapi/xapi_mgmt_iface.ml    |  5 +++--
 7 files changed, 45 insertions(+), 20 deletions(-)

diff --git a/ocaml/libs/http-svr/http.ml b/ocaml/libs/http-svr/http.ml
index 4bca0f2f1..a4d528d8c 100644
--- a/ocaml/libs/http-svr/http.ml
+++ b/ocaml/libs/http-svr/http.ml
@@ -363,7 +363,14 @@ let read_frame_header buf =
   let prefix = Bytes.sub_string buf 0 frame_header_length in
   try Scanf.sscanf prefix "FRAME %012d" (fun x -> Some x) with _ -> None
 
-let read_http_request_header fd =
+let set_socket_timeout fd t =
+  try Unix.(setsockopt_float fd SO_RCVTIMEO t)
+  with Unix.Unix_error (Unix.ENOTSOCK, _, _) ->
+    (* In the unit tests, the fd comes from a pipe... ignore *)
+    ()
+
+let read_http_request_header ~read_timeout fd =
+  Option.iter (fun t -> set_socket_timeout fd t) read_timeout ;
   let buf = Bytes.create 1024 in
   Unixext.really_read fd buf 0 6 ;
   (* return PROXY header if it exists, and then read up to FRAME header length (which also may not exist) *)
@@ -387,6 +394,7 @@ let read_http_request_header fd =
         Unixext.really_read fd buf 0 length ;
         (true, length)
   in
+  set_socket_timeout fd 0. ;
   (frame, Bytes.sub_string buf 0 headers_length, proxy)
 
 let read_http_response_header buf fd =
diff --git a/ocaml/libs/http-svr/http.mli b/ocaml/libs/http-svr/http.mli
index 7463dd5f2..b06ad105f 100644
--- a/ocaml/libs/http-svr/http.mli
+++ b/ocaml/libs/http-svr/http.mli
@@ -32,7 +32,8 @@ type authorization = Basic of string * string | UnknownAuth of string
 
 val make_frame_header : string -> string
 
-val read_http_request_header : Unix.file_descr -> bool * string * string option
+val read_http_request_header :
+  read_timeout:float option -> Unix.file_descr -> bool * string * string option
 
 val read_http_response_header : bytes -> Unix.file_descr -> int
 
diff --git a/ocaml/libs/http-svr/http_svr.ml b/ocaml/libs/http-svr/http_svr.ml
index 9017f94bf..77dea08bd 100644
--- a/ocaml/libs/http-svr/http_svr.ml
+++ b/ocaml/libs/http-svr/http_svr.ml
@@ -163,6 +163,13 @@ let response_badrequest ?req s =
   in
   response_error_html ?version s "400" "Bad Request" [] body
 
+let response_request_timeout s =
+  let body =
+    "<html><body><h1>HTTP 408 request timeout</h1>Timed out waiting for the \
+     request.</body></html>"
+  in
+  response_error_html s "408" "Request Timeout" [] body
+
 let response_internal_error ?req ?extra s =
   let version = Option.map get_return_version req in
   let extra =
@@ -315,9 +322,9 @@ exception Generic_error of string
 
 (** [request_of_bio_exn ic] reads a single Http.req from [ic] and returns it. On error
     	it simply throws an exception and doesn't touch the output stream. *)
-let request_of_bio_exn ~proxy_seen bio =
+let request_of_bio_exn ~proxy_seen ~read_timeout bio =
   let fd = Buf_io.fd_of bio in
-  let frame, headers, proxy' = Http.read_http_request_header fd in
+  let frame, headers, proxy' = Http.read_http_request_header ~read_timeout fd in
   let proxy = match proxy' with None -> proxy_seen | x -> x in
   let additional_headers =
     proxy |> Option.fold ~none:[] ~some:(fun p -> [("STUNNEL_PROXY", p)])
@@ -393,9 +400,9 @@ let request_of_bio_exn ~proxy_seen bio =
 
 (** [request_of_bio ic] returns [Some req] read from [ic], or [None]. If [None] it will have
     	already sent back a suitable error code and response to the client. *)
-let request_of_bio ?proxy_seen ic =
+let request_of_bio ?proxy_seen ~read_timeout ic =
   try
-    let r, proxy = request_of_bio_exn ~proxy_seen ic in
+    let r, proxy = request_of_bio_exn ~proxy_seen ~read_timeout ic in
     (Some r, proxy)
   with e ->
     D.warn "%s (%s)" (Printexc.to_string e) __LOC__ ;
@@ -419,6 +426,8 @@ let request_of_bio ?proxy_seen ic =
         (* Generic errors thrown during parsing *)
         | End_of_file ->
             ()
+        | Unix.Unix_error (Unix.EAGAIN, _, _) ->
+            response_request_timeout ss
         (* Premature termination of connection! *)
         | Unix.Unix_error (a, b, c) ->
             response_internal_error ss
@@ -487,7 +496,7 @@ let handle_one (x : 'a Server.t) ss context req =
     ) ;
     !finished
 
-let handle_connection (x : 'a Server.t) caller ss =
+let handle_connection ~header_read_timeout (x : 'a Server.t) caller ss =
   ( match caller with
   | Unix.ADDR_UNIX _ ->
       debug "Accepted unix connection"
@@ -502,20 +511,22 @@ let handle_connection (x : 'a Server.t) caller ss =
      just once per connection. To allow for the PROXY metadata (including e.g. the
      client IP) to be added to all request records on a connection, it must be passed
      along in the loop below. *)
-  let rec loop proxy_seen =
+  let rec loop ~read_timeout proxy_seen =
     (* 1. we must successfully parse a request *)
-    let req, proxy = request_of_bio ?proxy_seen ic in
+    let req, proxy = request_of_bio ?proxy_seen ~read_timeout ic in
     (* 2. now we attempt to process the request *)
     let finished =
       Option.fold ~none:true
         ~some:(handle_one x ss x.Server.default_context)
         req
     in
-    (* 3. do it again if the connection is kept open *)
+    (* 3. do it again if the connection is kept open, but without timeouts *)
     if not finished then
-      loop proxy
+      loop ~read_timeout:None proxy
   in
-  loop None ; debug "Closing connection" ; Unix.close ss
+  loop ~read_timeout:header_read_timeout None ;
+  debug "Closing connection" ;
+  Unix.close ss
 
 let bind ?(listen_backlog = 128) sockaddr name =
   let domain =
@@ -581,12 +592,11 @@ let socket_table = Hashtbl.create 10
 type socket = Unix.file_descr * string
 
 (* Start an HTTP server on a new socket *)
-let start ~conn_limit (x : 'a Server.t) (socket, name)
-    =
-let handler =
+let start ?header_read_timeout ~conn_limit (x : 'a Server.t) (socket, name) =
+  let handler =
     {
       Server_io.name
-    ; body= handle_connection x
+    ; body= handle_connection ~header_read_timeout x
     ; lock= Xapi_stdext_threads.Semaphore.create conn_limit
     }
   in
diff --git a/ocaml/libs/http-svr/http_svr.mli b/ocaml/libs/http-svr/http_svr.mli
index d0c79e4d4..40a5074ea 100644
--- a/ocaml/libs/http-svr/http_svr.mli
+++ b/ocaml/libs/http-svr/http_svr.mli
@@ -59,7 +59,8 @@ val bind : ?listen_backlog:int -> Unix.sockaddr -> string -> socket
 (* [bind_retry]: like [bind] but will catch (possibly transient exceptions) and retry *)
 val bind_retry : ?listen_backlog:int -> Unix.sockaddr -> socket
 
-val start : conn_limit:int -> 'a Server.t -> socket -> unit
+val start :
+  ?header_read_timeout:float -> conn_limit:int -> 'a Server.t -> socket -> unit
 
 val handle_one : 'a Server.t -> Unix.file_descr -> 'a -> Http.Request.t -> bool
 
diff --git a/ocaml/libs/http-svr/http_test.ml b/ocaml/libs/http-svr/http_test.ml
index 0633c58d1..e067a8b8a 100644
--- a/ocaml/libs/http-svr/http_test.ml
+++ b/ocaml/libs/http-svr/http_test.ml
@@ -200,7 +200,7 @@ let test_read_http_request_header _ =
   |> List.iter (fun (frame, proxy, header) ->
          with_fd (mk_header_string ~frame ~proxy ~header) (fun fd ->
              let actual_frame, actual_header, actual_proxy =
-               Http.read_http_request_header fd
+               Http.read_http_request_header ~read_timeout:None fd
              in
              assert (actual_frame = frame) ;
              assert (actual_header = header) ;
diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml
index 8dfd98538..4c874ff65 100644
--- a/ocaml/xapi/xapi_globs.ml
+++ b/ocaml/xapi/xapi_globs.ml
@@ -957,6 +957,9 @@ let sqlite3 = ref "/usr/bin/sqlite3"
 
 let samba_dir = "/var/lib/samba"
 
+let header_read_timeout_tcp = ref 10.
+(* Timeout in seconds for every read while reading HTTP headers (on TCP only) *)
+
 let conn_limit_tcp = ref 800
 
 let conn_limit_unix = ref 1024
@@ -1036,6 +1039,7 @@ let xapi_globs_spec =
   ; ( "winbind_update_closest_kdc_interval"
     , Float winbind_update_closest_kdc_interval
     )
+  ; ("header_read_timeout_tcp", Float header_read_timeout_tcp)
   ; ("conn_limit_tcp", Int conn_limit_tcp)
   ; ("conn_limit_unix", Int conn_limit_unix)
   ; ("conn_limit_clientcert", Int conn_limit_clientcert)
diff --git a/ocaml/xapi/xapi_mgmt_iface.ml b/ocaml/xapi/xapi_mgmt_iface.ml
index 381617f47..80a4852aa 100644
--- a/ocaml/xapi/xapi_mgmt_iface.ml
+++ b/ocaml/xapi/xapi_mgmt_iface.ml
@@ -81,8 +81,9 @@ end = struct
           ipv6_enabled := Unix.domain_of_sockaddr sockaddr = Unix.PF_INET6 ;
           Xapi_http.bind sockaddr
     in
-    Http_svr.start ~conn_limit:!Xapi_globs.conn_limit_tcp Xapi_http.server
-      socket ;
+    Http_svr.start
+      ~header_read_timeout:!Xapi_globs.header_read_timeout_tcp
+      ~conn_limit:!Xapi_globs.conn_limit_tcp Xapi_http.server socket ;
     management_servers := socket :: !management_servers ;
     if Pool_role.is_master () && addr = None then
       (* NB if we synchronously bring up the management interface on a master with a blank
-- 
2.31.1

