http-svr: switch from select to epoll

The select system call is inefficient and makes it impossible for a
process to use more than 1024 file descriptors.

Signed-off-by: Rob Hoes <[email protected]>

ocaml/libs/http-svr/dune

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

ocaml/libs/http-svr/server_io.ml

@@ -40,31 +40,32 @@ let handler_by_thread (h : handler) (s : Unix.file_descr)
 
 exception PleaseClose
 
-let set_intersect a b = List.filter (fun x -> List.mem x b) a
-
 let establish_server ?(signal_fds = []) forker handler sock =
+  let epoll = Polly.create () in
+  List.iter (fun fd -> Polly.add epoll fd Polly.Events.inp) (sock :: signal_fds) ;
   while true do
     try
-      let r, _, _ = Unix.select ([sock] @ signal_fds) [] [] (-1.) in
-      (* If any of the signal_fd is active then bail out *)
-      if set_intersect r signal_fds <> [] then raise PleaseClose ;
-      Xapi_stdext_threads.Semaphore.acquire handler.lock 1 ;
-      let s, caller = Unix.accept sock in
-      try
-        Unix.set_close_on_exec s ;
-        ignore (forker handler s caller)
-      with exc ->
-        (* NB provided 'forker' is configured to make a background thread then the
-           	     only way we can get here is if set_close_on_exec or Thread.create fails.
-           	     This means we haven't executed any code which could close the fd therefore
-           	     we should do it ourselves. *)
-        debug "Got exception in server_io.ml: %s" (Printexc.to_string exc) ;
-        log_backtrace () ;
-        Unix.close s ;
-        Thread.delay 30.0
+      ignore
+      @@ Polly.wait epoll 2 (-1) (fun _ fd _ ->
+             (* If any of the signal_fd is active then bail out *)
+             if List.mem fd signal_fds then raise PleaseClose ;
+             Xapi_stdext_threads.Semaphore.acquire handler.lock 1 ;
+             let s, caller = Unix.accept ~cloexec:true sock in
+             try ignore (forker handler s caller)
+             with exc ->
+               (* NB provided 'forker' is configured to make a background thread then the
+                  only way we can get here is if Thread.create fails.
+                  This means we haven't executed any code which could close the fd therefore
+                  we should do it ourselves. *)
+               debug "Got exception in server_io.ml: %s" (Printexc.to_string exc) ;
+               log_backtrace () ;
+               Unix.close s ;
+               Thread.delay 30.0
+         )
     with
     | PleaseClose ->
         debug "Caught PleaseClose: shutting down server thread" ;
+        Polly.close epoll ;
         raise PleaseClose
     | Unix.Unix_error (err, a, b) ->
         debug "Caught Unix exception in accept: %s in %s %s"