Merge pull request #80 from c-cube/wip-fix-http-of-dir-2024-02-18

improvements for http_of_dir

.github/workflows/main.yml

@@ -45,6 +45,6 @@ jobs:
       - run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd_camlzip
         if: ${{ matrix.os == 'ubuntu-latest' }}
 
-      - run: opam install logs -y
+      - run: opam install logs magic-mime -y
 
       - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip

dune-project

@@ -15,6 +15,7 @@
   (tags (http thread server tiny_httpd http_of_dir simplehttpserver))
   (depopts
     logs
+    magic-mime
     (mtime (>= 2.0)))
   (depends
     seq

src/Tiny_httpd.mli

@@ -1,7 +1,7 @@
 (** Tiny Http Server
 
     This library implements a very simple, basic HTTP/1.1 server using blocking
-    IOs and threads. Basic routing based on {!Scanf} is provided for convenience,
+    IOs and threads. Basic routing based is provided for convenience,
     so that several handlers can be registered.
 
     It is possible to use a thread pool, see {!create}'s argument [new_thread].

src/Tiny_httpd_dir.ml

@@ -94,8 +94,13 @@ let vfs_of_dir (top : string) : vfs =
     let list_dir f = Sys.readdir (top // f)
 
     let read_file_content f =
-      let ic = Unix.(openfile (top // f) [ O_RDONLY ] 0) in
-      Tiny_httpd_stream.of_fd ic
+      let fpath = top // f in
+      match Unix.stat fpath with
+      | { st_kind = Unix.S_REG; _ } ->
+        let ic = Unix.(openfile fpath [ O_RDONLY ] 0) in
+        let closed = ref false in
+        Tiny_httpd_stream.of_fd_close_noerr ~closed ic
+      | _ -> failwith (Printf.sprintf "not a regular file: %S" f)
 
     let create f =
       let oc = open_out_bin (top // f) in
@@ -310,18 +315,8 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
                 [ "Content-Type", "text/javascript" ]
               else if on_fs then (
                 (* call "file" util *)
-                try
-                  let p =
-                    Unix.open_process_in
-                      (Printf.sprintf "file -i -b %S" (top // path))
-                  in
-                  finally_
-                    ~h:(fun p -> ignore @@ Unix.close_process_in p)
-                    p
-                    (fun p ->
-                      try [ "Content-Type", String.trim (input_line p) ]
-                      with _ -> [])
-                with _ -> []
+                let ty = Tiny_httpd_mime_.mime_of_path (top // path) in
+                [ "content-type", ty ]
               ) else
                 []
             in
@@ -330,8 +325,12 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
               ~headers:(mime_type @ [ "Etag", Lazy.force mtime ])
               ~code:200 stream
           with e ->
-            S.Response.fail ~code:500 "error while reading file: %s"
-              (Printexc.to_string e)
+            let bt = Printexc.get_raw_backtrace () in
+            let msg = Printexc.to_string e in
+            Log.error (fun k ->
+                k "dir.get failed: %s@.%s" msg
+                  (Printexc.raw_backtrace_to_string bt));
+            S.Response.fail ~code:500 "error while reading file: %s" msg
         ))
   else
     S.add_route_handler server ~meth:`GET (route ()) (fun _ _ ->

src/Tiny_httpd_io.ml

@@ -34,15 +34,47 @@ module Input = struct
             close_in ic);
     }
 
-  let of_unix_fd ?(close_noerr = false) (fd : Unix.file_descr) : t =
+  let of_unix_fd ?(close_noerr = false) ~closed (fd : Unix.file_descr) : t =
+    let eof = ref false in
     {
-      input = (fun buf i len -> Unix.read fd buf i len);
+      input =
+        (fun buf i len ->
+          let n = ref 0 in
+          if (not !eof) && len > 0 then (
+            let continue = ref true in
+            while !continue do
+              (* Printf.eprintf "read %d B (from fd %d)\n%!" len (Obj.magic fd); *)
+              match Unix.read fd buf i len with
+              | n_ ->
+                n := n_;
+                continue := false
+              | exception
+                  Unix.Unix_error
+                    ( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
+                      | Unix.ECONNRESET | Unix.EPIPE ),
+                      _,
+                      _ ) ->
+                eof := true;
+                continue := false
+              | exception
+                  Unix.Unix_error
+                    ((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
+                ignore (Unix.select [ fd ] [] [] 1.)
+            done;
+            (* Printf.eprintf "read returned %d B\n%!" !n; *)
+            if !n = 0 then eof := true
+          );
+          !n);
       close =
         (fun () ->
+          if not !closed then (
+            closed := true;
+            eof := true;
             if close_noerr then (
               try Unix.close fd with _ -> ()
             ) else
-            Unix.close fd);
+              Unix.close fd
+          ));
     }
 
   let of_slice (i_bs : bytes) (i_off : int) (i_len : int) : t =
@@ -113,6 +145,70 @@ module Output = struct
 
       This can be a [Buffer.t], an [out_channel], a [Unix.file_descr], etc. *)
 
+  let of_unix_fd ?(close_noerr = false) ~closed ~(buf : Buf.t)
+      (fd : Unix.file_descr) : t =
+    Buf.clear buf;
+    let buf = Buf.bytes_slice buf in
+    let off = ref 0 in
+
+    let flush () =
+      if !off > 0 then (
+        let i = ref 0 in
+        while !i < !off do
+          (* Printf.eprintf "write %d bytes\n%!" (!off - !i); *)
+          match Unix.write fd buf !i (!off - !i) with
+          | 0 -> failwith "write failed"
+          | n -> i := !i + n
+          | exception
+              Unix.Unix_error
+                ( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
+                  | Unix.ECONNRESET | Unix.EPIPE ),
+                  _,
+                  _ ) ->
+            failwith "write failed"
+          | exception
+              Unix.Unix_error
+                ((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
+            ignore (Unix.select [] [ fd ] [] 1.)
+        done;
+        off := 0
+      )
+    in
+
+    let[@inline] flush_if_full_ () = if !off = Bytes.length buf then flush () in
+
+    let output_char c =
+      flush_if_full_ ();
+      Bytes.set buf !off c;
+      incr off;
+      flush_if_full_ ()
+    in
+    let output bs i len =
+      (* Printf.eprintf "output %d bytes (buffered)\n%!" len; *)
+      let i = ref i in
+      let len = ref len in
+      while !len > 0 do
+        flush_if_full_ ();
+        let n = min !len (Bytes.length buf - !off) in
+        Bytes.blit bs !i buf !off n;
+        i := !i + n;
+        len := !len - n;
+        off := !off + n
+      done;
+      flush_if_full_ ()
+    in
+    let close () =
+      if not !closed then (
+        closed := true;
+        flush ();
+        if close_noerr then (
+          try Unix.close fd with _ -> ()
+        ) else
+          Unix.close fd
+      )
+    in
+    { output; output_char; flush; close }
+
   (** [of_out_channel oc] wraps the channel into a {!Output.t}.
       @param close_noerr if true, then closing the result uses [close_out_noerr]
       instead of [close_out] to close [oc] *)
@@ -170,7 +266,7 @@ module Output = struct
        If [force=true] then write content of [buf] if it's simply non empty. *)
     let write_buf ~force () =
       let n = Buf.size buf in
-      if (force && n > 0) || n > 4_096 then (
+      if (force && n > 0) || n >= 4_096 then (
         output_string self (Printf.sprintf "%x\r\n" n);
         self.output (Buf.bytes_slice buf) 0 n;
         output_string self "\r\n";

src/Tiny_httpd_log.logs.ml

@@ -7,6 +7,10 @@ let debug k = Log.debug (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
 let error k = Log.err (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
 
 let setup ~debug () =
+  let mutex = Mutex.create () in
+  Logs.set_reporter_mutex
+    ~lock:(fun () -> Mutex.lock mutex)
+    ~unlock:(fun () -> Mutex.unlock mutex);
   Logs.set_reporter @@ Logs.format_reporter ();
   Logs.set_level ~all:true
     (Some

src/Tiny_httpd_mime_.dummy.ml

@@ -0,0 +1 @@
+let mime_of_path _ = "application/octet-stream"

src/Tiny_httpd_mime_.magic.ml

@@ -0,0 +1 @@
+let mime_of_path s = Magic_mime.lookup s

src/Tiny_httpd_mime_.mli

@@ -0,0 +1,2 @@
+
+val mime_of_path :  string -> string

src/Tiny_httpd_parse_.ml

@@ -0,0 +1,77 @@
+(** Basic parser for lines *)
+
+type 'a t = string -> int ref -> 'a
+
+open struct
+  let spf = Printf.sprintf
+end
+
+let[@inline] eof s off = !off = String.length s
+
+let[@inline] skip_space : unit t =
+ fun s off ->
+  while !off < String.length s && String.unsafe_get s !off = ' ' do
+    incr off
+  done
+
+let pos_int : int t =
+ fun s off : int ->
+  skip_space s off;
+  let n = ref 0 in
+  let continue = ref true in
+  while !off < String.length s && !continue do
+    match String.unsafe_get s !off with
+    | '0' .. '9' as c -> n := (!n * 10) + Char.code c - Char.code '0'
+    | ' ' | '\t' | '\n' -> continue := false
+    | c -> failwith @@ spf "expected int, got %C" c
+  done;
+  !n
+
+let pos_hex : int t =
+ fun s off : int ->
+  skip_space s off;
+  let n = ref 0 in
+  let continue = ref true in
+  while !off < String.length s && !continue do
+    match String.unsafe_get s !off with
+    | 'a' .. 'f' as c ->
+      incr off;
+      n := (!n * 16) + Char.code c - Char.code 'a' + 10
+    | 'A' .. 'F' as c ->
+      incr off;
+      n := (!n * 16) + Char.code c - Char.code 'A' + 10
+    | '0' .. '9' as c ->
+      incr off;
+      n := (!n * 16) + Char.code c - Char.code '0'
+    | ' ' | '\r' -> continue := false
+    | c -> failwith @@ spf "expected int, got %C" c
+  done;
+  !n
+
+(** Parse a word without spaces *)
+let word : string t =
+ fun s off ->
+  skip_space s off;
+  let start = !off in
+  let continue = ref true in
+  while !off < String.length s && !continue do
+    match String.unsafe_get s !off with
+    | ' ' | '\r' -> continue := false
+    | _ -> incr off
+  done;
+  if !off = start then failwith "expected word";
+  String.sub s start (!off - start)
+
+let exact str : unit t =
+ fun s off ->
+  skip_space s off;
+  let len = String.length str in
+  if !off + len > String.length s then
+    failwith @@ spf "unexpected EOF, expected %S" str;
+  for i = 0 to len - 1 do
+    let expected = String.unsafe_get str i in
+    let c = String.unsafe_get s (!off + i) in
+    if c <> expected then
+      failwith @@ spf "expected %S, got %C at position %d" str c i
+  done;
+  off := !off + len

src/Tiny_httpd_server.ml

@@ -173,6 +173,9 @@ module Request = struct
   let query self = self.query
   let get_header ?f self h = Headers.get ?f h self.headers
 
+  let remove_header k self =
+    { self with headers = Headers.remove k self.headers }
+
   let get_header_int self h =
     match get_header self h with
     | Some x -> (try Some (int_of_string x) with _ -> None)
@@ -243,12 +246,22 @@ module Request = struct
       let start_time = get_time_s () in
       let meth, path, version =
         try
-          let meth, path, version =
-            Scanf.sscanf line "%s %s HTTP/1.%d\r" (fun x y z -> x, y, z)
+          let off = ref 0 in
+          let meth = Tiny_httpd_parse_.word line off in
+          let path = Tiny_httpd_parse_.word line off in
+          let http_version = Tiny_httpd_parse_.word line off in
+          let version =
+            match http_version with
+            | "HTTP/1.1" -> 1
+            | "HTTP/1.0" -> 0
+            | v -> invalid_arg (Printf.sprintf "unsupported HTTP version: %s" v)
           in
-          if version != 0 && version != 1 then raise Exit;
           meth, path, version
-        with _ ->
+        with
+        | Invalid_argument msg ->
+          Log.error (fun k -> k "invalid request line: `%s`: %s" line msg);
+          raise (Bad_req (400, "Invalid request line"))
+        | _ ->
           Log.error (fun k -> k "invalid request line: `%s`" line);
           raise (Bad_req (400, "Invalid request line"))
       in
@@ -354,6 +367,10 @@ module Response = struct
   let set_headers headers self = { self with headers }
   let update_headers f self = { self with headers = f self.headers }
   let set_header k v self = { self with headers = Headers.set k v self.headers }
+
+  let remove_header k self =
+    { self with headers = Headers.remove k self.headers }
+
   let set_code code self = { self with code }
 
   let make_raw ?(headers = []) ~code body : t =
@@ -453,7 +470,8 @@ module Response = struct
     in
     let self = { self with headers; body } in
     Log.debug (fun k ->
-        k "output response: %s"
+        k "t[%d]: output response: %s"
+          (Thread.id @@ Thread.self ())
           (Format.asprintf "%a" pp { self with body = `String "<...>" }));
 
     (* write headers, using [buf] to batch writes *)
@@ -478,15 +496,25 @@ module Response = struct
          IO.Writer.write oc' w;
          IO.Output.close oc'
        with e ->
+         let bt = Printexc.get_raw_backtrace () in
          IO.Output.close oc';
-         raise e)
+         IO.Output.flush oc;
+         Printexc.raise_with_backtrace e bt)
     | `Stream str ->
-      (try
-         Byte_stream.output_chunked' ~buf oc str;
+      (match Byte_stream.output_chunked' ~buf oc str with
+      | () ->
+        Log.debug (fun k ->
+            k "t[%d]: done outputing stream" (Thread.id @@ Thread.self ()));
         Byte_stream.close str
-       with e ->
+      | exception e ->
+        let bt = Printexc.get_raw_backtrace () in
+        Log.error (fun k ->
+            k "t[%d]: outputing stream failed with %s"
+              (Thread.id @@ Thread.self ())
+              (Printexc.to_string e));
         Byte_stream.close str;
-         raise e));
+        IO.Output.flush oc;
+        Printexc.raise_with_backtrace e bt));
     IO.Output.flush oc
 end
 
@@ -897,6 +925,7 @@ module Unix_tcp_server_ = struct
   type t = {
     addr: string;
     port: int;
+    buf_pool: Buf.t Pool.t;
     max_connections: int;
     sem_max_connections: Sem_.t;
         (** semaphore to restrict the number of active concurrent connections *)
@@ -907,6 +936,11 @@ module Unix_tcp_server_ = struct
     mutable running: bool; (* TODO: use an atomic? *)
   }
 
+  let shutdown_silent_ fd =
+    try Unix.shutdown fd Unix.SHUTDOWN_ALL with _ -> ()
+
+  let close_silent_ fd = try Unix.close fd with _ -> ()
+
   let to_tcp_server (self : t) : IO.TCP_server.builder =
     {
       IO.TCP_server.serve =
@@ -959,27 +993,25 @@ module Unix_tcp_server_ = struct
           let handle_client_unix_ (client_sock : Unix.file_descr)
               (client_addr : Unix.sockaddr) : unit =
             Log.info (fun k ->
-                k "serving new client on %s"
+                k "t[%d]: serving new client on %s"
+                  (Thread.id @@ Thread.self ())
                   (Tiny_httpd_util.show_sockaddr client_addr));
+
+            if self.masksigpipe then
+              ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list);
+            Unix.set_nonblock client_sock;
+            Unix.setsockopt client_sock Unix.TCP_NODELAY true;
             Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout);
             Unix.(setsockopt_float client_sock SO_SNDTIMEO self.timeout);
+            Pool.with_resource self.buf_pool @@ fun buf ->
+            let closed = ref false in
             let oc =
-              IO.Output.of_out_channel @@ Unix.out_channel_of_descr client_sock
+              IO.Output.of_unix_fd ~close_noerr:true ~closed ~buf client_sock
             in
-            let ic = IO.Input.of_unix_fd client_sock in
-            handle.handle ~client_addr ic oc;
-            Log.info (fun k ->
-                k "done with client on %s, exiting"
-                @@ Tiny_httpd_util.show_sockaddr client_addr);
-            (try
-               Unix.shutdown client_sock Unix.SHUTDOWN_ALL;
-               Unix.close client_sock
-             with e ->
-               Log.error (fun k ->
-                   k "error when closing sock for client %s: %s"
-                     (Tiny_httpd_util.show_sockaddr client_addr)
-                     (Printexc.to_string e)));
-            ()
+            let ic =
+              IO.Input.of_unix_fd ~close_noerr:true ~closed client_sock
+            in
+            handle.handle ~client_addr ic oc
           in
 
           Unix.set_nonblock sock;
@@ -988,18 +1020,23 @@ module Unix_tcp_server_ = struct
             | client_sock, client_addr ->
               (* limit concurrency *)
               Sem_.acquire 1 self.sem_max_connections;
-
               (* Block INT/HUP while cloning to avoid children handling them.
                  When thread gets them, our Unix.accept raises neatly. *)
               ignore Unix.(sigprocmask SIG_BLOCK Sys.[ sigint; sighup ]);
               self.new_thread (fun () ->
                   try
-                    Unix.setsockopt client_sock Unix.TCP_NODELAY true;
                     handle_client_unix_ client_sock client_addr;
+                    Log.info (fun k ->
+                        k "t[%d]: done with client on %s, exiting"
+                          (Thread.id @@ Thread.self ())
+                        @@ Tiny_httpd_util.show_sockaddr client_addr);
+                    shutdown_silent_ client_sock;
+                    close_silent_ client_sock;
                     Sem_.release 1 self.sem_max_connections
                   with e ->
                     let bt = Printexc.get_raw_backtrace () in
-                    (try Unix.close client_sock with _ -> ());
+                    shutdown_silent_ client_sock;
+                    close_silent_ client_sock;
                     Sem_.release 1 self.sem_max_connections;
                     Log.error (fun k ->
                         k
@@ -1015,8 +1052,8 @@ module Unix_tcp_server_ = struct
               ignore (Unix.select [ sock ] [] [ sock ] 1.0 : _ * _ * _)
             | exception e ->
               Log.error (fun k ->
-                  k "Unix.accept or Thread.create raised an exception: %s"
-                    (Printexc.to_string e))
+                  k "Unix.accept raised an exception: %s" (Printexc.to_string e));
+              Thread.delay 0.01
           done;
 
           (* Wait for all threads to be done: this only works if all threads are done. *)
@@ -1035,6 +1072,10 @@ let create ?(masksigpipe = true) ?max_connections ?(timeout = 0.0) ?buf_size
     {
       Unix_tcp_server_.addr;
       new_thread;
+      buf_pool =
+        Pool.create ~clear:Buf.clear_and_zero
+          ~mk_item:(fun () -> Buf.create ?size:buf_size ())
+          ();
       running = true;
       port;
       sock;
@@ -1102,24 +1143,29 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
     )
   in
 
-  (* handle generic exception *)
-  let handle_exn e =
-    let resp =
-      Response.fail ~code:500 "server error: %s" (Printexc.to_string e)
-    in
-    if not Log.dummy then
+  let log_exn msg bt =
     Log.error (fun k ->
-          k "response to %s code=%d"
+        k "error while processing response for %s msg=%s@.%s"
           (Tiny_httpd_util.show_sockaddr client_addr)
-            resp.code);
+          msg
+          (Printexc.raw_backtrace_to_string bt))
+  in
+
+  (* handle generic exception *)
+  let handle_exn e bt : unit =
+    let msg = Printexc.to_string e in
+    let resp = Response.fail ~code:500 "server error: %s" msg in
+    if not Log.dummy then log_exn msg bt;
     Response.output_ ~buf:buf_res oc resp
   in
 
-  let handle_bad_req req e =
-    let resp =
-      Response.fail ~code:500 "server error: %s" (Printexc.to_string e)
-    in
-    log_response req resp;
+  let handle_bad_req req e bt =
+    let msg = Printexc.to_string e in
+    let resp = Response.fail ~code:500 "server error: %s" msg in
+    if not Log.dummy then (
+      log_exn msg bt;
+      log_response req resp
+    );
     Response.output_ ~buf:buf_res oc resp
   in
 
@@ -1165,7 +1211,9 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
         in
 
         UP.handle_connection client_addr handshake_st ic oc
-    with e -> handle_bad_req req e
+    with e ->
+      let bt = Printexc.get_raw_backtrace () in
+      handle_bad_req req e bt
   in
 
   let continue = ref true in
@@ -1182,7 +1230,9 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
       continue := false
     | Ok (Some req) ->
       Log.debug (fun k ->
-          k "parsed request: %s" (Format.asprintf "@[%a@]" Request.pp_ req));
+          k "t[%d]: parsed request: %s"
+            (Thread.id @@ Thread.self ())
+            (Format.asprintf "@[%a@]" Request.pp_ req));
 
       if Request.close_after_req req then continue := false;
 
@@ -1225,15 +1275,22 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
                continue := false;
              log_response req r;
              Response.output_ ~buf:buf_res oc r
-           with Sys_error _ -> continue := false
+           with Sys_error e ->
+             Log.debug (fun k ->
+                 k "error when writing response: %s@.connection broken" e);
+             continue := false
          in
 
          (* call handler *)
-         try handler oc req ~resp with Sys_error _ -> continue := false
+         try handler oc req ~resp
+         with Sys_error e ->
+           Log.debug (fun k ->
+               k "error while handling request: %s@.connection broken" e);
+           continue := false
        with
-      | Sys_error _ ->
+      | Sys_error e ->
         (* connection broken somehow *)
-        Log.debug (fun k -> k "connection broken");
+        Log.debug (fun k -> k "error: %s@. connection broken" e);
         continue := false
       | Bad_req (code, s) ->
         continue := false;
@@ -1241,12 +1298,15 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
         log_response req resp;
         Response.output_ ~buf:buf_res oc resp
       | Upgrade _ as e -> raise e
-      | e -> handle_bad_req req e)
+      | e ->
+        let bt = Printexc.get_raw_backtrace () in
+        handle_bad_req req e bt)
   in
 
   try
     while !continue && running self do
-      Log.debug (fun k -> k "read next request");
+      Log.debug (fun k ->
+          k "t[%d]: read next request" (Thread.id @@ Thread.self ()));
       handle_one_req ()
     done
   with
@@ -1254,7 +1314,9 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
     (* upgrades take over the whole connection, we won't process
        any further request *)
     handle_upgrade req up
-  | e -> handle_exn e
+  | e ->
+    let bt = Printexc.get_raw_backtrace () in
+    handle_exn e bt
 
 let client_handler (self : t) : IO.TCP_server.conn_handler =
   { IO.TCP_server.handle = client_handle_for self }

src/Tiny_httpd_server.mli

@@ -115,6 +115,10 @@ module Request : sig
   val set_header : string -> string -> 'a t -> 'a t
   (** [set_header k v req] sets [k: v] in the request [req]'s headers. *)
 
+  val remove_header : string -> 'a t -> 'a t
+  (** Remove one instance of this header.
+      @since NEXT_RELEASE *)
+
   val update_headers : (Headers.t -> Headers.t) -> 'a t -> 'a t
   (** Modify headers using the given function.
       @since 0.11 *)
@@ -243,6 +247,10 @@ module Response : sig
   (** Modify headers.
       @since 0.11 *)
 
+  val remove_header : string -> t -> t
+  (** Remove one instance of this header.
+      @since NEXT_RELEASE *)
+
   val set_headers : Headers.t -> t -> t
   (** Set all headers.
       @since 0.11 *)

src/Tiny_httpd_stream.ml

@@ -50,10 +50,11 @@ let of_input ?(buf_size = 16 * 1024) (ic : IO.Input.t) : t =
   make ~bs:(Bytes.create buf_size)
     ~close:(fun _ -> IO.Input.close ic)
     ~consume:(fun self n ->
+      assert (self.len >= n);
       self.off <- self.off + n;
       self.len <- self.len - n)
     ~fill:(fun self ->
-      if self.off >= self.len then (
+      if self.len = 0 then (
         self.off <- 0;
         self.len <- IO.Input.input ic self.bs 0 (Bytes.length self.bs)
       ))
@@ -66,22 +67,28 @@ let of_chan_ ?buf_size ic ~close_noerr : t =
 let of_chan ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:false
 let of_chan_close_noerr ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:true
 
-let of_fd_ ?buf_size ~close_noerr ic : t =
-  let inc = IO.Input.of_unix_fd ~close_noerr ic in
+let of_fd_ ?buf_size ~close_noerr ~closed ic : t =
+  let inc = IO.Input.of_unix_fd ~close_noerr ~closed ic in
   of_input ?buf_size inc
 
-let of_fd ?buf_size fd : t = of_fd_ ?buf_size ~close_noerr:false fd
-let of_fd_close_noerr ?buf_size fd : t = of_fd_ ?buf_size ~close_noerr:true fd
+let of_fd ?buf_size ~closed fd : t =
+  of_fd_ ?buf_size ~closed ~close_noerr:false fd
 
-let rec iter f (self : t) : unit =
+let of_fd_close_noerr ?buf_size ~closed fd : t =
+  of_fd_ ?buf_size ~closed ~close_noerr:true fd
+
+let iter f (self : t) : unit =
+  let continue = ref true in
+  while !continue do
     self.fill_buf ();
-  if self.len = 0 then
+    if self.len = 0 then (
+      continue := false;
       self.close ()
-  else (
+    ) else (
       f self.bs self.off self.len;
-    self.consume self.len;
-    (iter [@tailcall]) f self
+      self.consume self.len
     )
+  done
 
 let to_chan (oc : out_channel) (self : t) = iter (output oc) self
 let to_chan' (oc : IO.Output.t) (self : t) = iter (IO.Output.output oc) self
@@ -116,7 +123,7 @@ let of_string s : t = of_bytes (Bytes.unsafe_of_string s)
 let with_file ?buf_size file f =
   let ic = Unix.(openfile file [ O_RDONLY ] 0) in
   try
-    let x = f (of_fd ?buf_size ic) in
+    let x = f (of_fd ?buf_size ~closed:(ref false) ic) in
     Unix.close ic;
     x
   with e ->
@@ -127,12 +134,13 @@ let read_all ?(buf = Buf.create ()) (self : t) : string =
   let continue = ref true in
   while !continue do
     self.fill_buf ();
-    if self.len > 0 then (
+    if self.len = 0 then
+      continue := false
+    else (
+      assert (self.len > 0);
       Buf.add_bytes buf self.bs self.off self.len;
       self.consume self.len
-    );
-    assert (self.len >= 0);
-    if self.len = 0 then continue := false
+    )
   done;
   Buf.contents_and_clear buf
 
@@ -165,10 +173,10 @@ let read_line_into (self : t) ~buf : unit =
     done;
     if !j - self.off < self.len then (
       assert (Bytes.get self.bs !j = '\n');
+      (* line without '\n' *)
       Buf.add_bytes buf self.bs self.off (!j - self.off);
-      (* without \n *)
+      (* consume line + '\n' *)
       self.consume (!j - self.off + 1);
-      (* remove \n *)
       continue := false
     ) else (
       Buf.add_bytes buf self.bs self.off self.len;
@@ -260,7 +268,10 @@ let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
       if String.trim line = "" then
         0
       else (
-        try Scanf.sscanf line "%x %s@\r" (fun n _ext -> n)
+        try
+          let off = ref 0 in
+          let n = Tiny_httpd_parse_.pos_hex line off in
+          n
         with _ ->
           raise (fail (spf "cannot read chunk size from line %S" line))
       )
@@ -273,7 +284,7 @@ let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
     ~bs:(Bytes.create (16 * 4096))
     ~fill:(fun self ->
       (* do we need to refill? *)
-      if self.off >= self.len then (
+      if self.len = 0 then (
         if !chunk_size = 0 && !refill then chunk_size := read_next_chunk_len ();
         self.off <- 0;
         self.len <- 0;
@@ -299,8 +310,12 @@ let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
 
 let output_chunked' ?buf (oc : IO.Output.t) (self : t) : unit =
   let oc' = IO.Output.chunk_encoding ?buf oc ~close_rec:false in
-  to_chan' oc' self;
-  IO.Output.close oc'
+  match to_chan' oc' self with
+  | () -> IO.Output.close oc'
+  | exception e ->
+    let bt = Printexc.get_raw_backtrace () in
+    IO.Output.close oc';
+    Printexc.raise_with_backtrace e bt
 
 (* print a stream as a series of chunks *)
 let output_chunked ?buf (oc : out_channel) (self : t) : unit =

src/Tiny_httpd_stream.mli

@@ -74,10 +74,10 @@ val of_chan : ?buf_size:int -> in_channel -> t
 val of_chan_close_noerr : ?buf_size:int -> in_channel -> t
 (** Same as {!of_chan} but the [close] method will never fail. *)
 
-val of_fd : ?buf_size:int -> Unix.file_descr -> t
+val of_fd : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t
 (** Make a buffered stream from the given file descriptor. *)
 
-val of_fd_close_noerr : ?buf_size:int -> Unix.file_descr -> t
+val of_fd_close_noerr : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t
 (** Same as {!of_fd} but the [close] method will never fail. *)
 
 val of_bytes : ?i:int -> ?len:int -> bytes -> t

src/Tiny_httpd_util.ml

@@ -11,7 +11,11 @@ let percent_encode ?(skip = fun _ -> false) s =
     s;
   Buffer.contents buf
 
-let hex_int (s : string) : int = Scanf.sscanf s "%x" (fun x -> x)
+let int_of_hex_nibble = function
+  | '0' .. '9' as c -> Char.code c - Char.code '0'
+  | 'a' .. 'f' as c -> 10 + Char.code c - Char.code 'a'
+  | 'A' .. 'F' as c -> 10 + Char.code c - Char.code 'A'
+  | _ -> invalid_arg "string: invalid hex"
 
 let percent_decode (s : string) : _ option =
   let buf = Buffer.create (String.length s) in
@@ -21,7 +25,10 @@ let percent_decode (s : string) : _ option =
       match String.get s !i with
       | '%' ->
         if !i + 2 < String.length s then (
-          (match hex_int @@ String.sub s (!i + 1) 2 with
+          (match
+             (int_of_hex_nibble (String.get s (!i + 1)) lsl 4)
+             + int_of_hex_nibble (String.get s (!i + 2))
+           with
           | n -> Buffer.add_char buf (Char.chr n)
           | exception _ -> raise Exit);
           i := !i + 3

src/bin/http_of_dir.ml

@@ -4,8 +4,8 @@ module D = Tiny_httpd_dir
 module Pf = Printf
 module Log = Tiny_httpd.Log
 
-let serve ~config (dir : string) addr port j : _ result =
-  let server = S.create ~max_connections:j ~addr ~port () in
+let serve ~config ~timeout (dir : string) addr port j : _ result =
+  let server = S.create ~max_connections:j ~addr ~port ~timeout () in
   let after_init () =
     Printf.printf "serve directory %s on http://%(%s%):%d\n%!" dir
       (if S.is_ipv6 server then
@@ -31,6 +31,7 @@ let main () =
   let dir_ = ref "." in
   let addr = ref "127.0.0.1" in
   let port = ref 8080 in
+  let timeout = ref 30. in
   let j = ref 32 in
   Arg.parse
     (Arg.align
@@ -41,6 +42,7 @@ let main () =
          "-p", Set_int port, " alias to --port";
          "--dir", Set_string dir_, " directory to serve (default: \".\")";
          "--debug", Unit (Log.setup ~debug:true), " debug mode";
+         "--timeout", Arg.Set_float timeout, " TCP timeout on sockets";
          ( "--upload",
            Unit (fun () -> config.upload <- true),
            " enable file uploading" );
@@ -75,7 +77,7 @@ let main () =
        ])
     (fun s -> dir_ := s)
     "http_of_dir [options] [dir]";
-  match serve ~config !dir_ !addr !port !j with
+  match serve ~config ~timeout:!timeout !dir_ !addr !port !j with
   | Ok () -> ()
   | Error e -> raise e
 

src/camlzip/Tiny_httpd_camlzip.ml

@@ -148,6 +148,11 @@ let decompress_req_stream_ ~buf_size (req : BS.t S.Request.t) : _ S.Request.t =
        let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in
        Some (req', decode_gzip_stream_)
   *)
+  | Some "deflate" ->
+    let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in
+    req
+    |> S.Request.remove_header "Transfer-Encoding"
+    |> S.Request.set_body body'
   | Some s when has_deflate s ->
     (match Scanf.sscanf s "deflate, %s" (fun s -> s) with
     | tr' ->

src/dune

@@ -1,9 +1,13 @@
 (library
   (name tiny_httpd)
   (public_name tiny_httpd)
+  (private_modules Tiny_httpd_mime_ Tiny_httpd_parse_)
   (libraries threads seq unix
+             (select Tiny_httpd_mime_.ml from
+              (magic-mime -> Tiny_httpd_mime_.magic.ml)
+              ( -> Tiny_httpd_mime_.dummy.ml))
              (select Tiny_httpd_log.ml from
-              (logs -> Tiny_httpd_log.logs.ml)
+              (logs logs.fmt fmt.tty -> Tiny_httpd_log.logs.ml)
               (-> Tiny_httpd_log.default.ml)))
   (wrapped false))
 

tiny_httpd.opam

@@ -24,6 +24,7 @@ depends: [
 ]
 depopts: [
   "logs"
+  "magic-mime"
   "mtime" {>= "2.0"}
 ]
 build: [