Merge pull request #4675 from lindig/private/christianlin/CA-364138

 CA-364138 XSI-1217: fix FD leak, Unix.EMFILE

ocaml/xapi-guard/src/main.ml

@@ -22,6 +22,12 @@ let ret v = v >>= Lwt.return_ok |> Rpc_lwt.T.put
 
 let sockets = Hashtbl.create 127
 
+let log_fds () =
+  let count stream = Lwt_stream.fold (fun _ n -> n + 1) stream 0 in
+  Lwt_unix.files_of_directory "/proc/self/fd" |> count >>= fun fds ->
+  D.info "file descriptors in use: %d" fds ;
+  Lwt.return_unit
+
 module Persistent = struct
   type args = {
       vm_uuid: Varstore_privileged_interface.Uuidm.t
@@ -71,6 +77,7 @@ let listen_for_vm {Persistent.vm_uuid; path; gid} =
   D.debug "resume: listening on socket %s for VM %s" path vm_uuid_str ;
   safe_unlink path >>= fun () ->
   make_server_rpcfn path vm_uuid_str >>= fun stop_server ->
+  log_fds () >>= fun () ->
   Hashtbl.add sockets path (stop_server, (vm_uuid, gid)) ;
   Lwt_unix.chmod path 0o660 >>= fun () -> Lwt_unix.chown path 0 gid
 

ocaml/xapi-guard/src/varstored_interface.ml

@@ -162,10 +162,9 @@ let rec wait_for_file_to_appear path =
       Conduit_lwt_unix.connect ~ctx:Conduit_lwt_unix.default_ctx
         (`Unix_domain_socket (`File path))
     )
-    (fun (_, ic, _oc) ->
+    (fun (_, ic, oc) ->
       D.debug "Socket at %s works" path ;
-      (* do not close both channels, or we get an EBADF *)
-      Lwt_io.close ic
+      Lwt_io.close oc >>= fun () -> Lwt_io.close ic
     )
     (fun e ->
       D.debug "Waiting for file %s to appear (%s)" path (Printexc.to_string e) ;