Commits

Dmitry Grebeniuk  committed f6a445c

debugging IO_Lwt.establish_server with environment variable 'IO_SERVER_DEBUG=1'

  • Participants
  • Parent commits 0153395

Comments (0)

Files changed (1)

   [ Invalid_argument _ -> Sys.Signal_default ]
 ;
 
+value server_debug =
+  try Sys.getenv "IO_SERVER_DEBUG" = "1"
+  with [ Not_found -> False ]
+;
+
+value dbg fmt = Printf.ksprintf
+  (fun s -> Printf.eprintf "IO_Lwt.server: %s\n%!" s)
+  fmt
+;
+
 value establish_server ?buffer_size ?(backlog=5) sockaddr f =
   let sock = Lwt_unix.socket
     (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in
     ) in
   let (abort_waiter, abort_wakener) = Lwt.wait () in
   let (finish_waiter, finish_wakener) = Lwt.wait () in
-  let abort_waiter = abort_waiter >>= fun [`Shutdown -> return `Shutdown] in
+  let abort_waiter =
+    abort_waiter >>= fun x ->
+    ( if server_debug then dbg "abort_waiter" else ()
+    ; return x
+    ) >>= fun [`Shutdown -> return `Shutdown]
+  in
   let old_sigpipe_beh = sys_signal_or_default Sys.sigpipe Sys.Signal_ignore in
   let sigpipe_finally () =
     ignore
       )
   in
   let rec loop () =
+    let () = if server_debug then dbg "loop" else () in
     Lwt.pick
-      [ Lwt_unix.accept sock >>= fun x -> return (`Accept x)
+      [ Lwt_unix.accept sock >>= fun x ->
+          let () = if server_debug then dbg "accept_sock done" else () in
+          return (`Accept x)
       ; abort_waiter
       ]
     >>= fun
-      [ `Accept(fd, _addr) ->
+      [ `Accept (fd, _addr) ->
+          let () = if server_debug then dbg "`Accept" else () in
           let () =
             (try Lwt_unix.set_close_on_exec fd
              with [Invalid_argument _ -> ()]) in
+          let () = if server_debug then dbg "after close_on_exec" else () in
           let close = lazy begin
+            let () = if server_debug then dbg "close1" else () in
             Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL;
-            Lwt_unix.close fd
+            let () = if server_debug then dbg "close2" else () in
+            Lwt_unix.close fd >>= fun () ->
+            let () = if server_debug then dbg "close3" else () in
+            return ()
           end in
           let () =
-            f ( Lwt_io.of_fd ?buffer_size ~mode:Lwt_io.input
-                  ~close:(fun () -> Lazy.force close) fd
-              , Lwt_io.of_fd ?buffer_size ~mode:Lwt_io.output
-                  ~close:(fun () -> Lazy.force close) fd
-              )
+            let in_ch = Lwt_io.of_fd ?buffer_size ~mode:Lwt_io.input
+              ~close:(fun () -> Lazy.force close) fd in
+            let () = if server_debug then dbg "made in_ch" else () in
+            let out_ch = Lwt_io.of_fd ?buffer_size ~mode:Lwt_io.output
+               ~close:(fun () -> Lazy.force close) fd in
+            let () = if server_debug then dbg "made out_ch" else () in
+            f (in_ch, out_ch)
           in
+          let () = if server_debug then dbg "user function executed" else () in
           loop ()
       | `Shutdown ->
+          let () = if server_debug then dbg "`Shutdown" else () in
           Lwt_unix.close sock >>= fun () ->
+          let () = if server_debug then dbg "socket closed" else () in
           (match sockaddr with
             [ Unix.ADDR_UNIX path when path <> "" && path.[0] <> '\x00' ->
                 ( Unix.unlink path
           ) >>= fun () ->
           let () = sigpipe_finally () in
           return (Lwt.wakeup finish_wakener ())
+      | _ ->
+          let () = if server_debug then dbg "not `Accept|`Shutdown" else () in
+          raise Exit
       ]
   in
-  ( ignore (Lwt.catch loop (fun e -> (sigpipe_finally (); raise e)))
+  ( ignore
+      ( if server_debug then dbg "entering loop" else ()
+      ; Lwt.catch
+          loop
+          (fun e ->
+             ( if server_debug
+               then dbg "exception in loop: %s" (Printexc.to_string e)
+               else ()
+             ; sigpipe_finally ()
+             ; raise e
+             )
+          ) >>= fun () ->
+        let () = if server_debug then dbg "after 'catch loop'" else () in
+        return ()
+      )
   ; { shutdown = lazy (Lwt.wakeup abort_wakener `Shutdown)
     ; wait_server = finish_waiter
     }