Merge pull request #4817 from robhoes/http

CA-368579: Mitigations against DoS attacks by unauthenticated clients

ocaml/database/database_server_main.ml

@@ -81,7 +81,7 @@ let _ =
           (Http_svr.BufIO remote_database_access_handler_v1) ;
         Http_svr.Server.add_handler server Http.Post "/post_remote_db_access_v2"
           (Http_svr.BufIO remote_database_access_handler_v2) ;
-        Http_svr.start server socket ;
+        Http_svr.start ~conn_limit:1024 server socket ;
         Printf.printf "server listening\n%!" ;
         if !self_test then (
           Printf.printf "Running unit-tests\n%!" ;

ocaml/libs/http-svr/dune

@@ -7,6 +7,7 @@
   (libraries
     astring
     base64
+    polly
     rpclib
     sha
     stunnel

ocaml/libs/http-svr/http.ml

@@ -26,6 +26,10 @@ exception Method_not_implemented
 
 exception Malformed_url of string
 
+exception Timeout
+
+exception Too_large
+
 module D = Debug.Make (struct let name = "http" end)
 
 open D
@@ -281,14 +285,20 @@ let header_len_header = Printf.sprintf "\r\n%s:" Hdr.header_len
 
 let header_len_value_len = 5
 
-let read_up_to buf already_read marker fd =
+let read_up_to ?deadline ?max buf already_read marker fd =
   let marker = Scanner.make marker in
   let hl_marker = Scanner.make header_len_header in
   let b = ref 0 in
   (* next free byte in [buf] *)
   let header_len = ref None in
   let header_len_value_at = ref None in
   while not (Scanner.matched marker) do
+    Option.iter
+      (fun d ->
+        if Mtime.Span.compare (Mtime_clock.elapsed ()) d > 0 then
+          raise Timeout
+      )
+      deadline ;
     let safe_to_read =
       match (!header_len_value_at, !header_len) with
       | None, None ->
@@ -302,6 +312,7 @@ let read_up_to buf already_read marker fd =
 		Printf.fprintf stderr "b = %d; safe_to_read = %d\n" !b safe_to_read;
 		flush stderr;
 *)
+    Option.iter (fun m -> if !b + safe_to_read > m then raise Too_large) max ;
     let n =
       if !b < already_read then
         min safe_to_read (already_read - !b)
@@ -348,8 +359,6 @@ let read_up_to buf already_read marker fd =
   done ;
   !b
 
-let read_http_header buf fd = read_up_to buf 0 end_of_headers fd
-
 let smallest_request = "GET / HTTP/1.0\r\n\r\n"
 
 (* let smallest_response = "HTTP/1.0 200 OK\r\n\r\n" *)
@@ -365,30 +374,59 @@ 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 buf = Bytes.create 1024 in
-  Unixext.really_read fd buf 0 6 ;
+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 ~total_timeout ~max_length fd =
+  Option.iter (fun t -> set_socket_timeout fd t) read_timeout ;
+  let buf = Bytes.create (Option.value ~default:1024 max_length) in
+  let deadline =
+    Option.map
+      (fun t ->
+        let start = Mtime_clock.elapsed () in
+        let timeout_ns = int_of_float (t *. 1e9) in
+        Mtime.Span.(add start (timeout_ns * ns))
+      )
+      total_timeout
+  in
+  let check_timeout_and_read x y =
+    Option.iter
+      (fun d ->
+        if Mtime.Span.compare (Mtime_clock.elapsed ()) d > 0 then
+          raise Timeout
+      )
+      deadline ;
+    Unixext.really_read fd buf x y
+  in
+  check_timeout_and_read 0 6 ;
   (* return PROXY header if it exists, and then read up to FRAME header length (which also may not exist) *)
   let proxy =
     match Bytes.sub_string buf 0 6 with
     | "PROXY " ->
-        let proxy_header_length = read_up_to buf 6 "\r\n" fd in
+        let proxy_header_length = read_up_to ?deadline buf 6 "\r\n" fd in
         (* chop 'PROXY ' from the beginning, and '\r\n' from the end *)
         let proxy = Bytes.sub_string buf 6 (proxy_header_length - 6 - 2) in
-        Unixext.really_read fd buf 0 frame_header_length ;
+        check_timeout_and_read 0 frame_header_length ;
         Some proxy
     | _ ->
-        Unixext.really_read fd buf 6 (frame_header_length - 6) ;
+        check_timeout_and_read 6 (frame_header_length - 6) ;
         None
   in
   let frame, headers_length =
     match read_frame_header buf with
     | None ->
-        (false, read_up_to buf frame_header_length end_of_headers fd)
+        let max = Option.map (fun m -> m - frame_header_length) max_length in
+        ( false
+        , read_up_to ?deadline ?max buf frame_header_length end_of_headers fd
+        )
     | Some length ->
-        Unixext.really_read fd buf 0 length ;
+        check_timeout_and_read 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 =

ocaml/libs/http-svr/http.mli

@@ -28,13 +28,20 @@ exception Method_not_implemented
 
 exception Forbidden
 
-type authorization = Basic of string * string | UnknownAuth of string
+exception Timeout
+
+exception Too_large
 
-val read_http_header : bytes -> Unix.file_descr -> int
+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
+  -> total_timeout:float option
+  -> max_length:int option
+  -> Unix.file_descr
+  -> bool * string * string option
 
 val read_http_response_header : bytes -> Unix.file_descr -> int
 

ocaml/libs/http-svr/http_proxy.ml

@@ -15,9 +15,6 @@
 module D = Debug.Make (struct let name = "http_proxy" end)
 
 open D
-open Xmlrpc_client
-
-let finally = Xapi_stdext_pervasives.Pervasiveext.finally
 
 let one request fromfd s =
   let open Xapi_stdext_unix in
@@ -53,57 +50,3 @@ let one request fromfd s =
   | m ->
       error "Proxy doesn't support: %s" (Http.string_of_method_t m) ;
       Http_svr.response_forbidden ~req:request fromfd
-
-let server = ref None
-
-let m = Mutex.create ()
-
-let http_proxy src_ip src_port transport =
-  let tcp_connection _ fromfd =
-    (* NB 'fromfd' is accepted within the server_io module and it expects us to close it *)
-    finally
-      (fun () ->
-        let bio = Buf_io.of_fd fromfd in
-        let request, _ = Http_svr.request_of_bio bio in
-        Option.iter
-          (fun request -> with_transport transport (one request fromfd))
-          request
-      )
-      (fun () -> Unix.close fromfd)
-  in
-  try
-    let addr = Unix.inet_addr_of_string src_ip in
-    let sockaddr = Unix.ADDR_INET (addr, src_port) in
-    Xapi_stdext_threads.Threadext.Mutex.execute m (fun () ->
-        (* shutdown any server which currently exists *)
-        Option.iter (fun server -> server.Server_io.shutdown ()) !server ;
-        (* Make sure we don't try to double-close the server *)
-        server := None ;
-        let handler = {Server_io.name= "http_proxy"; body= tcp_connection} in
-        let sock =
-          Unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0
-        in
-        ( try
-            (* Make sure exceptions cause the socket to be closed *)
-            Unix.set_close_on_exec sock ;
-            Unix.setsockopt sock Unix.SO_REUSEADDR true ;
-            ( match sockaddr with
-            | Unix.ADDR_INET _ ->
-                Xapi_stdext_unix.Unixext.set_tcp_nodelay sock true
-            | _ ->
-                ()
-            ) ;
-            Unix.bind sock sockaddr ; Unix.listen sock 128
-          with e ->
-            debug "Caught exception in Http_svr.bind (closing socket): %s"
-              (Printexc.to_string e) ;
-            Unix.close sock ;
-            raise e
-        ) ;
-        let s = Server_io.server handler sock in
-        server := Some s
-    )
-  with e ->
-    error "Caught exception setting up proxy from internal network: %s"
-      (Printexc.to_string e) ;
-    raise e

ocaml/libs/http-svr/http_proxy.mli

@@ -15,7 +15,3 @@
 val one : Http.Request.t -> Unix.file_descr -> Unix.file_descr -> unit
 (** [one request input output] proxies the single HTTP request [request]
     from [input] to [output] *)
-
-val http_proxy : string -> int -> Xmlrpc_client.transport -> unit
-(** [http_proxy ip port transport] establishes an HTTP proxy on [ip]:[port]
-    which forwards all requests via [transport] *)