From 0d1bccfd1b85097bb09a70f4013f16823d0c57f0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 18 Feb 2024 23:44:10 -0500 Subject: [PATCH 01/11] better logging, do not error on close --- src/Tiny_httpd_dir.ml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index b3fb6fb7..ad048449 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -95,7 +95,7 @@ let vfs_of_dir (top : string) : vfs = let read_file_content f = let ic = Unix.(openfile (top // f) [ O_RDONLY ] 0) in - Tiny_httpd_stream.of_fd ic + Tiny_httpd_stream.of_fd_close_noerr ic let create f = let oc = open_out_bin (top // f) in @@ -330,8 +330,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 _ _ -> From d9b3731207c956ebe6ca897a630097bcaa52b654 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 21 Feb 2024 22:03:31 -0500 Subject: [PATCH 02/11] feat: optional dep on magic-mime for http_of_dir --- .gitmodules | 0 dune-project | 1 + src/Tiny_httpd_dir.ml | 14 ++------------ src/dune | 6 +++++- src/mime_.dummy.ml | 1 + src/mime_.magic.ml | 1 + src/mime_.mli | 2 ++ tiny_httpd.opam | 1 + 8 files changed, 13 insertions(+), 13 deletions(-) delete mode 100644 .gitmodules create mode 100644 src/mime_.dummy.ml create mode 100644 src/mime_.magic.ml create mode 100644 src/mime_.mli diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index e69de29b..00000000 diff --git a/dune-project b/dune-project index 9ccb6023..301047b7 100644 --- a/dune-project +++ b/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 diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index ad048449..75c1062b 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -310,18 +310,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 = Mime_.mime_of_path (top // path) in + [ "content-type", ty ] ) else [] in diff --git a/src/dune b/src/dune index b20bb974..fca51e45 100644 --- a/src/dune +++ b/src/dune @@ -1,9 +1,13 @@ (library (name tiny_httpd) (public_name tiny_httpd) + (private_modules mime_) (libraries threads seq unix + (select mime_.ml from + (magic-mime -> mime_.magic.ml) + ( -> 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)) diff --git a/src/mime_.dummy.ml b/src/mime_.dummy.ml new file mode 100644 index 00000000..dc944b1c --- /dev/null +++ b/src/mime_.dummy.ml @@ -0,0 +1 @@ +let mime_of_path _ = "application/octet-stream" diff --git a/src/mime_.magic.ml b/src/mime_.magic.ml new file mode 100644 index 00000000..72fcd345 --- /dev/null +++ b/src/mime_.magic.ml @@ -0,0 +1 @@ +let mime_of_path s = Magic_mime.lookup s diff --git a/src/mime_.mli b/src/mime_.mli new file mode 100644 index 00000000..1831c02d --- /dev/null +++ b/src/mime_.mli @@ -0,0 +1,2 @@ + +val mime_of_path : string -> string diff --git a/tiny_httpd.opam b/tiny_httpd.opam index a2ce739c..a5224f40 100644 --- a/tiny_httpd.opam +++ b/tiny_httpd.opam @@ -24,6 +24,7 @@ depends: [ ] depopts: [ "logs" + "magic-mime" "mtime" {>= "2.0"} ] build: [ From a39df1ba474c090de5cb2f5c6917fa0c5871ea05 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 21 Feb 2024 22:04:06 -0500 Subject: [PATCH 03/11] CI --- .github/workflows/main.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index ddeacbab..0f509b9d 100644 --- a/.github/workflows/main.yml +++ b/.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 From e69f1b7c8c5193034c50a049d2f8ec0a2d209cb8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 21 Feb 2024 22:06:24 -0500 Subject: [PATCH 04/11] feat dir: only read content of regular files no need to look into sockets, pipes, etc. --- src/Tiny_httpd_dir.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index 75c1062b..03adecb3 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -94,8 +94,12 @@ 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_close_noerr 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 + Tiny_httpd_stream.of_fd_close_noerr ic + | _ -> failwith (Printf.sprintf "not a regular file: %S" f) let create f = let oc = open_out_bin (top // f) in From 01faca284f5b501848ff3a02dccb14e468419ac2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 21 Feb 2024 22:07:12 -0500 Subject: [PATCH 05/11] fix IO: use a loop for `IO.Input.of_unix_fd`; handle nonblocking --- src/Tiny_httpd_io.ml | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/src/Tiny_httpd_io.ml b/src/Tiny_httpd_io.ml index 207ba9a5..74faa98d 100644 --- a/src/Tiny_httpd_io.ml +++ b/src/Tiny_httpd_io.ml @@ -35,10 +35,31 @@ module Input = struct } let of_unix_fd ?(close_noerr = false) (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.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 () -> + eof := true; if close_noerr then ( try Unix.close fd with _ -> () ) else @@ -170,7 +191,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"; From 88b9f1e411b9644da43db7945f2a9f77c81548a1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 21 Feb 2024 22:07:49 -0500 Subject: [PATCH 06/11] fix stream: fix a bug, use a loop in another place --- src/Tiny_httpd_stream.ml | 39 ++++++++++++++++++++++----------------- 1 file changed, 22 insertions(+), 17 deletions(-) diff --git a/src/Tiny_httpd_stream.ml b/src/Tiny_httpd_stream.ml index 5f8cf0a7..ce1002eb 100644 --- a/src/Tiny_httpd_stream.ml +++ b/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) )) @@ -73,15 +74,18 @@ let of_fd_ ?buf_size ~close_noerr ic : t = 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 rec iter f (self : t) : unit = - self.fill_buf (); - if self.len = 0 then - self.close () - else ( - f self.bs self.off self.len; - self.consume self.len; - (iter [@tailcall]) f self - ) +let iter f (self : t) : unit = + let continue = ref true in + while !continue do + self.fill_buf (); + if self.len = 0 then ( + continue := false; + self.close () + ) else ( + f self.bs self.off self.len; + 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 @@ -127,12 +131,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 +170,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; @@ -273,7 +278,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; From 353f0925b40fff2111990a9bd360d5aff6ea60f0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 21 Feb 2024 22:08:58 -0500 Subject: [PATCH 07/11] server: better logging, better error handling --- src/Tiny_httpd_server.ml | 134 ++++++++++++++++++++++++--------------- 1 file changed, 83 insertions(+), 51 deletions(-) diff --git a/src/Tiny_httpd_server.ml b/src/Tiny_httpd_server.ml index 4094fba5..0ab23d7d 100644 --- a/src/Tiny_httpd_server.ml +++ b/src/Tiny_httpd_server.ml @@ -453,7 +453,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 +479,21 @@ 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; - Byte_stream.close str - with e -> - Byte_stream.close str; - raise e)); + (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 + | exception e -> + let bt = Printexc.get_raw_backtrace () in + IO.Output.flush oc; + Byte_stream.close str; + Printexc.raise_with_backtrace e bt)); IO.Output.flush oc end @@ -907,6 +914,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 = @@ -961,25 +973,19 @@ module Unix_tcp_server_ = struct Log.info (fun k -> k "serving new client on %s" (Tiny_httpd_util.show_sockaddr client_addr)); + (* + if self.masksigpipe then + ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list); + *) + 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); let oc = - IO.Output.of_out_channel @@ Unix.out_channel_of_descr client_sock + IO.Output.of_out_channel ~close_noerr:true + @@ Unix.out_channel_of_descr 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 client_sock in + handle.handle ~client_addr ic oc in Unix.set_nonblock sock; @@ -988,18 +994,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 +1026,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. *) @@ -1102,24 +1113,29 @@ let client_handle_for (self : t) ~client_addr ic oc : unit = ) in + let log_exn msg bt = + Log.error (fun k -> + k "error while processing response for %s msg=%s@.%s" + (Tiny_httpd_util.show_sockaddr client_addr) + msg + (Printexc.raw_backtrace_to_string bt)) + 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 - Log.error (fun k -> - k "response to %s code=%d" - (Tiny_httpd_util.show_sockaddr client_addr) - resp.code); + 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 +1181,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 +1200,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 +1245,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 +1268,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 +1284,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 } From d56ffb3a08beec5a3e45431ee45a82fd041ffd32 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 21 Feb 2024 22:09:18 -0500 Subject: [PATCH 08/11] http_of_dir: ability to setup socket timeout --- src/bin/http_of_dir.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index 77953d7b..468f7e32 100644 --- a/src/bin/http_of_dir.ml +++ b/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 From 225c21b4cc691cf5ae3aa1bce44d2224f8eb0a57 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 22 Feb 2024 18:23:18 -0500 Subject: [PATCH 09/11] error handling, and bugfix (idempotent closing of Unix.fd) --- src/Tiny_httpd_dir.ml | 3 +- src/Tiny_httpd_io.ml | 87 +++++++++++++++++++++++++++++++++++--- src/Tiny_httpd_log.logs.ml | 4 ++ src/Tiny_httpd_server.ml | 27 +++++++++--- src/Tiny_httpd_stream.ml | 21 ++++++--- src/Tiny_httpd_stream.mli | 4 +- 6 files changed, 123 insertions(+), 23 deletions(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index 03adecb3..2252c678 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -98,7 +98,8 @@ let vfs_of_dir (top : string) : vfs = match Unix.stat fpath with | { st_kind = Unix.S_REG; _ } -> let ic = Unix.(openfile fpath [ O_RDONLY ] 0) in - Tiny_httpd_stream.of_fd_close_noerr ic + 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 = diff --git a/src/Tiny_httpd_io.ml b/src/Tiny_httpd_io.ml index 74faa98d..407f5108 100644 --- a/src/Tiny_httpd_io.ml +++ b/src/Tiny_httpd_io.ml @@ -34,7 +34,7 @@ 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 = @@ -48,6 +48,14 @@ module Input = struct | 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), _, _) -> @@ -59,11 +67,14 @@ module Input = struct !n); close = (fun () -> - eof := true; - 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 = @@ -134,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] *) diff --git a/src/Tiny_httpd_log.logs.ml b/src/Tiny_httpd_log.logs.ml index 43d67fc8..f2cc8f56 100644 --- a/src/Tiny_httpd_log.logs.ml +++ b/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 diff --git a/src/Tiny_httpd_server.ml b/src/Tiny_httpd_server.ml index 0ab23d7d..bdac6110 100644 --- a/src/Tiny_httpd_server.ml +++ b/src/Tiny_httpd_server.ml @@ -491,8 +491,12 @@ module Response = struct Byte_stream.close str | exception e -> let bt = Printexc.get_raw_backtrace () in - IO.Output.flush oc; + Log.error (fun k -> + k "t[%d]: outputing stream failed with %s" + (Thread.id @@ Thread.self ()) + (Printexc.to_string e)); Byte_stream.close str; + IO.Output.flush oc; Printexc.raise_with_backtrace e bt)); IO.Output.flush oc end @@ -904,6 +908,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 *) @@ -971,20 +976,24 @@ 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 ~close_noerr:true - @@ 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 ~close_noerr:true ~closed client_sock in - let ic = IO.Input.of_unix_fd ~close_noerr:true client_sock in handle.handle ~client_addr ic oc in @@ -1046,6 +1055,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; diff --git a/src/Tiny_httpd_stream.ml b/src/Tiny_httpd_stream.ml index ce1002eb..30754e91 100644 --- a/src/Tiny_httpd_stream.ml +++ b/src/Tiny_httpd_stream.ml @@ -67,12 +67,15 @@ 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 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 @@ -120,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 -> @@ -304,8 +307,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 = diff --git a/src/Tiny_httpd_stream.mli b/src/Tiny_httpd_stream.mli index 23f8c298..a5b5636d 100644 --- a/src/Tiny_httpd_stream.mli +++ b/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 From 5018df5ff8fda1558684c991b51a58d944d9ca45 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 22 Feb 2024 18:33:57 -0500 Subject: [PATCH 10/11] fix: avoid collisions in `Mime_` private module --- src/Tiny_httpd_dir.ml | 2 +- src/{mime_.dummy.ml => Tiny_httpd_mime_.dummy.ml} | 0 src/{mime_.magic.ml => Tiny_httpd_mime_.magic.ml} | 0 src/{mime_.mli => Tiny_httpd_mime_.mli} | 0 src/dune | 8 ++++---- 5 files changed, 5 insertions(+), 5 deletions(-) rename src/{mime_.dummy.ml => Tiny_httpd_mime_.dummy.ml} (100%) rename src/{mime_.magic.ml => Tiny_httpd_mime_.magic.ml} (100%) rename src/{mime_.mli => Tiny_httpd_mime_.mli} (100%) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index 2252c678..c619c217 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -315,7 +315,7 @@ 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 *) - let ty = Mime_.mime_of_path (top // path) in + let ty = Tiny_httpd_mime_.mime_of_path (top // path) in [ "content-type", ty ] ) else [] diff --git a/src/mime_.dummy.ml b/src/Tiny_httpd_mime_.dummy.ml similarity index 100% rename from src/mime_.dummy.ml rename to src/Tiny_httpd_mime_.dummy.ml diff --git a/src/mime_.magic.ml b/src/Tiny_httpd_mime_.magic.ml similarity index 100% rename from src/mime_.magic.ml rename to src/Tiny_httpd_mime_.magic.ml diff --git a/src/mime_.mli b/src/Tiny_httpd_mime_.mli similarity index 100% rename from src/mime_.mli rename to src/Tiny_httpd_mime_.mli diff --git a/src/dune b/src/dune index fca51e45..eee6fef7 100644 --- a/src/dune +++ b/src/dune @@ -1,11 +1,11 @@ (library (name tiny_httpd) (public_name tiny_httpd) - (private_modules mime_) + (private_modules Tiny_httpd_mime_) (libraries threads seq unix - (select mime_.ml from - (magic-mime -> mime_.magic.ml) - ( -> mime_.dummy.ml)) + (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 logs.fmt fmt.tty -> Tiny_httpd_log.logs.ml) (-> Tiny_httpd_log.default.ml))) From da55098a7add70273af21c43b11223f5db43d173 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 22 Feb 2024 18:58:26 -0500 Subject: [PATCH 11/11] remove some uses of scanf in parsing --- src/Tiny_httpd.mli | 2 +- src/Tiny_httpd_parse_.ml | 77 +++++++++++++++++++++++++++++++ src/Tiny_httpd_server.ml | 25 ++++++++-- src/Tiny_httpd_server.mli | 8 ++++ src/Tiny_httpd_stream.ml | 5 +- src/Tiny_httpd_util.ml | 11 ++++- src/camlzip/Tiny_httpd_camlzip.ml | 5 ++ src/dune | 2 +- 8 files changed, 126 insertions(+), 9 deletions(-) create mode 100644 src/Tiny_httpd_parse_.ml diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index 4634edc8..b4cc6e89 100644 --- a/src/Tiny_httpd.mli +++ b/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]. diff --git a/src/Tiny_httpd_parse_.ml b/src/Tiny_httpd_parse_.ml new file mode 100644 index 00000000..39430889 --- /dev/null +++ b/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 diff --git a/src/Tiny_httpd_server.ml b/src/Tiny_httpd_server.ml index bdac6110..f023324c 100644 --- a/src/Tiny_httpd_server.ml +++ b/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 = diff --git a/src/Tiny_httpd_server.mli b/src/Tiny_httpd_server.mli index b91022d2..c9ee0763 100644 --- a/src/Tiny_httpd_server.mli +++ b/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 *) diff --git a/src/Tiny_httpd_stream.ml b/src/Tiny_httpd_stream.ml index 30754e91..a845c8bf 100644 --- a/src/Tiny_httpd_stream.ml +++ b/src/Tiny_httpd_stream.ml @@ -268,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)) ) diff --git a/src/Tiny_httpd_util.ml b/src/Tiny_httpd_util.ml index 9ec935ae..73617702 100644 --- a/src/Tiny_httpd_util.ml +++ b/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 diff --git a/src/camlzip/Tiny_httpd_camlzip.ml b/src/camlzip/Tiny_httpd_camlzip.ml index e815641d..7d390211 100644 --- a/src/camlzip/Tiny_httpd_camlzip.ml +++ b/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' -> diff --git a/src/dune b/src/dune index eee6fef7..74542c39 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,7 @@ (library (name tiny_httpd) (public_name tiny_httpd) - (private_modules Tiny_httpd_mime_) + (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)