Anonymous avatar Anonymous committed 46ffdd3

got 'establish_server' from lwt, slightly enhanced it

Comments (0)

Files changed (2)

-<**/*> : camlp4r
+<**/*> : camlp4r, warn_A
 
 <iO_Lwt.ml> : pkg_lwt, pkg_lwt.unix
 value bind = Lwt.(=<<);
 
 value bind_rev = Lwt.bind;
+value ( >>= ) = Lwt.bind;
+
 
 value error = Lwt.fail;
 
 
 (********************************************************)
 
-type server = Lwt_io.server;
+(* copypasted from lwt_io.ml, modified:
+   - to revised syntax,
+   - more strict code (no more warnings),
+   - added "wait_server"
+ *)
 
+type server =
+  { shutdown : Lazy.t unit
+  ; wait_server : Lwt.t unit
+  }
+;
+
+value shutdown_server server = Lazy.force server.shutdown
+;
+
+value wait_server server = server.wait_server
+;
+
+value establish_server ?buffer_size ?(backlog=5) sockaddr f =
+  let sock = Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in
+  let () =
+    ( Lwt_unix.setsockopt sock Unix.SO_REUSEADDR True
+    ; Lwt_unix.bind sock sockaddr
+    ; Lwt_unix.listen sock backlog
+    ) 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 rec loop () =
+    Lwt.pick
+      [ Lwt_unix.accept sock >>= fun x -> return (`Accept x)
+      ; abort_waiter
+      ]
+    >>= fun
+      [ `Accept(fd, _addr) ->
+          let () =
+            (try Lwt_unix.set_close_on_exec fd
+             with [Invalid_argument _ -> ()]) in
+          let close = lazy begin
+            Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL;
+            Lwt_unix.close fd
+          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
+              )
+          in
+          loop ()
+      | `Shutdown ->
+          Lwt_unix.close sock >>= fun () ->
+          (match sockaddr with
+            [ Unix.ADDR_UNIX path when path <> "" && path.[0] <> '\x00' ->
+                ( Unix.unlink path
+                ; return ()
+                )
+            | Unix.ADDR_UNIX _ | Unix.ADDR_INET _ ->
+                return ()
+            ]
+          ) >>= fun () ->
+          return (Lwt.wakeup finish_wakener ())
+      ]
+  in
+  ( ignore (loop ())
+  ; { shutdown = lazy (Lwt.wakeup abort_wakener `Shutdown)
+    ; wait_server = finish_waiter
+    }
+  )
+;
+
+(* end of copypaste *)
+
+
+(********************************************************)
+
+(*
 value establish_server ?buffer_size ?backlog sa func =
   Lwt_io.establish_server ?buffer_size ?backlog sa func
 ;
 
 value shutdown_server = Lwt_io.shutdown_server
 ;
+*)
+
 
 value run_and_ignore_result = Lwt.ignore_result
 ;
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.