From 4bdca82fcecaf70fe9240dafc4601d63f3332acd Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Sat, 11 Dec 2021 09:29:41 -0500
Subject: [PATCH] wip: try to make non-block read, block write work

---
 src/Tiny_httpd.ml      | 38 ++++++++++++++++----------------------
 src/bin/http_of_dir.ml |  7 ++++++-
 2 files changed, 22 insertions(+), 23 deletions(-)

diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml
index 508bff26..164004e5 100644
--- a/src/Tiny_httpd.ml
+++ b/src/Tiny_httpd.ml
@@ -66,41 +66,27 @@ module Byte_stream = struct
     bs_close=(fun () -> ());
   }
 
-  let of_chan_ ~close ic : t =
-    let i = ref 0 in
-    let len = ref 0 in
-    let buf = Bytes.make 4096 ' ' in
-    { bs_fill_buf=(fun () ->
-      if !i >= !len then (
-        i := 0;
-        len := input ic buf 0 (Bytes.length buf);
-      );
-      buf, !i,!len - !i);
-      bs_consume=(fun n -> i := !i + n);
-      bs_close=(fun () -> close ic)
-    }
-
-  let of_chan = of_chan_ ~close:close_in
-  let of_chan_close_noerr = of_chan_ ~close:close_in_noerr
-
   exception Timeout
 
-  let of_descr_ ?(timeout=(-1.0)) ~close ic : t =
+  let of_descr_ ?(timeout=(-1.0)) ~close fd : t =
     let i = ref 0 in
     let len = ref 0 in
     let buf = Bytes.make 4096 ' ' in
+
+    Unix.set_nonblock fd;
     { bs_fill_buf=(fun () ->
       if !i >= !len then (
         i := 0;
 
         let rec wait() =
-          let to_read,_,_ = Unix.select [ic] [] [] timeout in
+          let to_read,_,_ = Unix.select [fd] [] [] timeout in
           if to_read = [] then raise Timeout;
           read()
         and read() =
-          try len := Unix.read ic buf 0 (Bytes.length buf)
+          try len := Unix.read fd buf 0 (Bytes.length buf)
           with
           | Unix.Unix_error (EAGAIN, _, _) -> read()
+          | Sys_blocked_io
           | Unix.Unix_error (EWOULDBLOCK, _, _) ->
             (* FIXME: we should decrease the timeout by however long was spent in [select] *)
             wait()
@@ -109,10 +95,18 @@ module Byte_stream = struct
       );
       buf, !i,!len - !i);
       bs_consume=(fun n -> i := !i + n);
-      bs_close=(fun () -> close ic)
+      bs_close=close
     }
 
-  let of_descr = of_descr_ ~close:Unix.close
+  let of_descr ?timeout fd = of_descr_ ?timeout ~close:(fun() -> Unix.close fd) fd
+
+  let of_chan ic =
+    let fd = Unix.descr_of_in_channel ic in
+    of_descr_ ~timeout:(-1.0) ~close:(fun() -> close_in ic) fd
+
+  let of_chan_close_noerr ic =
+    let fd = Unix.descr_of_in_channel ic in
+    of_descr_ ~timeout:(-1.0) ~close:(fun() -> close_in_noerr ic) fd
 
   let rec iter f (self:t) : unit =
     let s, i, len = self.bs_fill_buf () in
diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml
index b695b3bf..b7aa3108 100644
--- a/src/bin/http_of_dir.ml
+++ b/src/bin/http_of_dir.ml
@@ -6,6 +6,7 @@ type config = {
   mutable addr: string;
   mutable port: int;
   mutable upload: bool;
+  mutable max_keep_alive: float; (* per connection timeout *)
   mutable max_upload_size: int;
   mutable auto_index_html: bool;
   mutable delete: bool;
@@ -17,6 +18,7 @@ let default_config () : config = {
   port=8080;
   delete=false;
   upload=false;
+  max_keep_alive=10.;
   max_upload_size = 10 * 1024 * 1024;
   auto_index_html=true;
   j=32;
@@ -111,7 +113,10 @@ let date_of_time (f:float) : string =
    *)
 
 let serve ~config (dir:string) : _ result =
-  let server = S.create ~max_connections:config.j ~addr:config.addr ~port:config.port () in
+  let server =
+    S.create ~max_connections:config.j
+      ~max_keep_alive:config.max_keep_alive
+      ~addr:config.addr ~port:config.port () in
   Printf.printf "serve directory %s on http://%(%s%):%d\n%!"
     dir (if S.is_ipv6 server then "[%s]" else "%s") config.addr config.port;
   if config.delete then (