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 close_noerr then (
-            try Unix.close fd with _ -> ()
-          ) else
-            Unix.close fd);
+          if not !closed then (
+            closed := true;
+            eof := true;
+            if close_noerr then (
+              try Unix.close fd with _ -> ()
+            ) else
+              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