From 6dceabdd6ccaa0989e1923a4ee14d3c581fa91d7 Mon Sep 17 00:00:00 2001 From: craff Date: Sun, 19 Dec 2021 00:54:17 -1000 Subject: [PATCH] Revert "use bigstring and map_file" This reverts commit 306712053924176943ec834247f0e021883cd87a. --- src/Tiny_httpd.ml | 79 ++++++++----------------------- src/Tiny_httpd.mli | 15 +----- src/Tiny_httpd_dir.ml | 43 ++++++++++------- src/Tiny_httpd_dir.mli | 1 + src/camlzip/Tiny_httpd_camlzip.ml | 23 +++------ src/dune | 2 +- tests/download_chunked.sh | 9 ---- 7 files changed, 54 insertions(+), 118 deletions(-) diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index 258fdb0f..ad416b99 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -107,7 +107,6 @@ module Byte_stream = struct | None -> Bytes.length s - i ) in - let i = ref i in { bs_fill_buf=(fun () -> s, !i, !len); bs_close=(fun () -> len := 0); @@ -117,29 +116,6 @@ module Byte_stream = struct let of_string s : t = of_bytes (Bytes.unsafe_of_string s) - let of_big_string ?(buf_size=16 * 1024) ?(i=0) ?len s : t = - let len = - ref ( - match len with - | Some n -> - if n > Bigstring.length s - i then invalid_arg "Byte_stream.of_bytes"; - n - | None -> Bigstring.length s - i - ) - in - let buf = Bytes.make buf_size ' ' in - let i = ref i in - let len_buf = ref 0 in - { bs_fill_buf=(fun () -> - if !i >= !len_buf then ( - i := 0; len_buf := min buf_size !len; - Bigstring.blit_to_bytes s !i buf 0 !len_buf; - ); - buf, !i,!len_buf - !i); - bs_consume=(fun n -> i := !i + n; len := !len - n); - bs_close=(fun () -> len_buf := 0) - } - let with_file ?buf_size file f = let ic = open_in file in try @@ -615,9 +591,7 @@ end *) module Response = struct - type body = - | String of string | BigString of Bigstring.t - | Stream of byte_stream | Void + type body = [`String of string | `Stream of byte_stream | `Void] type t = { code: Response_code.t; headers: Headers.t; @@ -635,22 +609,15 @@ module Response = struct let headers = Headers.set "Content-Length" (string_of_int (String.length body)) headers in - { code; headers; body=String body; } - - let make_raw_big ?(headers=[]) ~code body : t = - (* add content length to response *) - let headers = - Headers.set "Content-Length" (string_of_int (Bigstring.length body)) headers - in - { code; headers; body=BigString body; } + { code; headers; body=`String body; } let make_raw_stream ?(headers=[]) ~code body : t = (* add content length to response *) let headers = Headers.set "Transfer-Encoding" "chunked" headers in - { code; headers; body=Stream body; } + { code; headers; body=`Stream body; } let make_void ?(headers=[]) ~code () : t = - { code; headers; body=Void; } + { code; headers; body=`Void; } let make_string ?headers r = match r with | Ok body -> make_raw ?headers ~code:200 body @@ -661,10 +628,9 @@ module Response = struct | Error (code,msg) -> make_raw ?headers ~code msg let make ?headers r : t = match r with - | Ok (String body) -> make_raw ?headers ~code:200 body - | Ok (BigString body) -> make_raw_big ?headers ~code:200 body - | Ok (Stream body) -> make_raw_stream ?headers ~code:200 body - | Ok Void -> make_void ?headers ~code:200 () + | Ok (`String body) -> make_raw ?headers ~code:200 body + | Ok (`Stream body) -> make_raw_stream ?headers ~code:200 body + | Ok `Void -> make_void ?headers ~code:200 () | Error (code,msg) -> make_raw ?headers ~code msg let fail ?headers ~code fmt = @@ -674,10 +640,9 @@ module Response = struct let pp out self : unit = let pp_body out = function - | String s -> Format.fprintf out "%S" s - | BigString _ -> Format.pp_print_string out "" - | Stream _ -> Format.pp_print_string out "" - | Void -> () + | `String s -> Format.fprintf out "%S" s + | `Stream _ -> Format.pp_print_string out "" + | `Void -> () in Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" self.code Headers.pp self.headers pp_body self.body @@ -701,16 +666,12 @@ module Response = struct let output_ (oc:out_channel) (self:t) : unit = Printf.fprintf oc "HTTP/1.1 %d %s\r\n" self.code (Response_code.descr self.code); let body, is_chunked = match self.body with - | String s when String.length s > 1024 * 500 -> + | `String s when String.length s > 1024 * 500 -> (* chunk-encode large bodies *) - Stream (Byte_stream.of_string s), true - | BigString s when Bigstring.length s > 1024 * 500 -> - (* chunk-encode large bodies *) - Stream (Byte_stream.of_big_string s), true - | String _ as b -> b, false - | BigString _ as b -> b, false - | Stream _ as b -> b, true - | Void as b -> b, false + `Stream (Byte_stream.of_string s), true + | `String _ as b -> b, false + | `Stream _ as b -> b, true + | `Void as b -> b, false in let headers = if is_chunked then ( @@ -721,15 +682,13 @@ module Response = struct in let self = {self with headers; body} in _debug (fun k->k "output response: %s" - (Format.asprintf "%a" pp {self with body=String "<…>"})); + (Format.asprintf "%a" pp {self with body=`String "<…>"})); List.iter (fun (k,v) -> Printf.fprintf oc "%s: %s\r\n" k v) headers; output_string oc "\r\n"; begin match body with - | String "" | Void -> () - | String s -> output_string oc s; - | BigString s -> Format.fprintf (Format.formatter_of_out_channel oc) - "%a%!" Bigstring.print s - | Stream str -> output_stream_chunked_ oc str; + | `String "" | `Void -> () + | `String s -> output_string oc s; + | `Stream str -> output_stream_chunked_ oc str; end; flush oc end diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index aab4b806..539f440c 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -141,9 +141,6 @@ module Byte_stream : sig val of_string : string -> t - val of_big_string : ?buf_size:int -> ?i:int -> ?len:int -> Bigstring.t -> t - (** Make a buffered stream from the given big string. *) - val iter : (bytes -> int -> int -> unit) -> t -> unit (** Iterate on the chunks of the stream @since 0.3 *) @@ -334,9 +331,7 @@ end the client to answer a {!Request.t}*) module Response : sig - type body = - | String of string | BigString of Bigstring.t - | Stream of byte_stream | Void + type body = [`String of string | `Stream of byte_stream | `Void] (** Body of a response, either as a simple string, or a stream of bytes, or nothing (for server-sent events). *) @@ -375,14 +370,6 @@ module Response : sig (** Make a response from its raw components, with a string body. Use [""] to not send a body at all. *) - val make_raw_big : - ?headers:Headers.t -> - code:Response_code.t -> - Bigstring.t -> - t - (** Make a response from its raw components, with a big string body. - Use [""] to not send a body at all. *) - val make_raw_stream : ?headers:Headers.t -> code:Response_code.t -> diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index c471d25c..55b70d3a 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -7,6 +7,7 @@ type dir_behavior = type config = { mutable download: bool; + mutable mem_cache: bool; mutable dir_behavior: dir_behavior; mutable delete: bool; mutable upload: bool; @@ -15,6 +16,7 @@ type config = { let default_config () : config = { download=true + ; mem_cache=false ; dir_behavior=Forbidden ; delete=false ; upload=false @@ -41,7 +43,7 @@ let header_html = "Content-Type", "text/html" let (//) = Filename.concat let encode_path s = U.percent_encode ~skip:(function '/' -> true|_->false) s -let _decode_path s = match U.percent_decode s with Some s->s | None -> s +let decode_path s = match U.percent_decode s with Some s->s | None -> s let is_hidden s = String.length s>0 && s.[0] = '.' @@ -162,24 +164,30 @@ let add_dir_path ~config ~dir ~prefix server = (fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed"); ); + let cache = Hashtbl.create 101 in + if config.download then ( S.add_route_handler server ~meth:`GET S.Route.(exact_path prefix (rest_of_path_urlencoded)) (fun path req -> let full_path = dir // path in - let stat = - try Unix.stat full_path - with _ -> S.Response.fail_raise ~code:403 "Cannot access file" - in - let mtime = stat.Unix.st_mtime in - let mtime_str = Printf.sprintf "mtime: %f" mtime in + let mtime = lazy ( + try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime + with _ -> S.Response.fail_raise ~code:403 "Cannot access file" + ) in + try + if not config.mem_cache then raise Not_found; + let (ans, mtime0) = Hashtbl.find cache path in + if mtime <> mtime0 then raise Not_found; + ans + with Not_found -> + let ans = if contains_dot_dot full_path then ( S.Response.fail ~code:403 "Path is forbidden"; ) else if not (Sys.file_exists full_path) then ( S.Response.fail ~code:404 "File not found"; - ) else - if S.Request.get_header req "If-None-Match" = Some mtime_str then ( - S._debug (fun k->k "cached object %S (etag: %S)" path mtime_str); + ) else if S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime) then ( + S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime)); S.Response.make_raw ~code:304 "" ) else if Sys.is_directory full_path then ( S._debug (fun k->k "list dir %S (topdir %S)" full_path dir); @@ -198,15 +206,13 @@ let add_dir_path ~config ~dir ~prefix server = | Lists -> let body = html_list_dir ~top:dir path ~parent in S.Response.make_string - ~headers:[header_html; "ETag", mtime_str] + ~headers:[header_html; "ETag", Lazy.force mtime] (Ok body) | Forbidden -> S.Response.make_raw ~code:405 "listing dir not allowed" ) else ( try - let bs = Bigstring_unix.with_map_file ~flags:[Open_rdonly] full_path - (fun s -> s) - in + let ic = open_in full_path in let mime_type = if Filename.extension full_path = ".css" then ( ["Content-Type", "text/css"] @@ -220,11 +226,14 @@ let add_dir_path ~config ~dir ~prefix server = with _ -> []) with _ -> [] in - S.Response.make_raw_big - ~headers:(mime_type@["Etag", mtime_str]) - ~code:200 bs + S.Response.make_raw_stream + ~headers:(mime_type@["Etag", Lazy.force mtime]) + ~code:200 (S.Byte_stream.of_chan ic) with e -> S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)) + in + Hashtbl.replace cache path (ans,mtime); + ans ) ) else ( S.add_route_handler server ~meth:`GET diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli index a5cbf213..57e6dcb2 100644 --- a/src/Tiny_httpd_dir.mli +++ b/src/Tiny_httpd_dir.mli @@ -4,6 +4,7 @@ type dir_behavior = type config = { mutable download: bool; + mutable mem_cache: bool; mutable dir_behavior: dir_behavior; mutable delete: bool; mutable upload: bool; diff --git a/src/camlzip/Tiny_httpd_camlzip.ml b/src/camlzip/Tiny_httpd_camlzip.ml index 7bf53f5a..f9a394fc 100644 --- a/src/camlzip/Tiny_httpd_camlzip.ml +++ b/src/camlzip/Tiny_httpd_camlzip.ml @@ -178,7 +178,7 @@ let compress_resp_stream_ if accept_deflate req then ( match resp.body with - | String s when String.length s > compress_above -> + | `String s when String.length s > compress_above -> (* big string, we compress *) S._debug (fun k->k "encode str response with deflate (size %d, threshold %d)" @@ -188,27 +188,15 @@ let compress_resp_stream_ in resp |> S.Response.update_headers update_headers - |> S.Response.set_body (Stream body) + |> S.Response.set_body (`Stream body) - | BigString s when Bigstring.length s > compress_above -> - (* big string, we compress *) - S._debug - (fun k->k "encode str response with deflate (size %d, threshold %d)" - (Bigstring.length s) compress_above); - let body = - encode_deflate_stream_ ~buf_size @@ S.Byte_stream.of_big_string s - in - resp - |> S.Response.update_headers update_headers - |> S.Response.set_body (Stream body) - - | Stream str -> + | `Stream str -> S._debug (fun k->k "encode stream response with deflate"); resp |> S.Response.update_headers update_headers - |> S.Response.set_body (Stream (encode_deflate_stream_ ~buf_size str)) + |> S.Response.set_body (`Stream (encode_deflate_stream_ ~buf_size str)) - | String _ | BigString _ | Void -> resp + | `String _ | `Void -> resp ) else resp let middleware @@ -227,3 +215,4 @@ let setup let m = middleware ?compress_above ?buf_size () in S._debug (fun k->k "setup gzip support"); S.add_middleware ~stage:`Encoding server m + diff --git a/src/dune b/src/dune index 40391f32..29a2fb12 100644 --- a/src/dune +++ b/src/dune @@ -2,6 +2,6 @@ (library (name tiny_httpd) (public_name tiny_httpd) - (libraries threads bigstring bigstring-unix) + (libraries threads) (flags :standard -safe-string -warn-error -a+8) (wrapped false)) diff --git a/tests/download_chunked.sh b/tests/download_chunked.sh index ca70f77b..2fc4e3c5 100755 --- a/tests/download_chunked.sh +++ b/tests/download_chunked.sh @@ -7,15 +7,6 @@ PID=$! sleep 0.1 -echo download1 1>&2 -curl -N "http://localhost:${PORT}/foo_50" -o data2 \ - -H 'Tranfer-encoding: chunked' - -echo download2 1>&2 -curl -N "http://localhost:${PORT}/foo_50" -o data2 \ - -H 'Tranfer-encoding: chunked' - -echo download3 1>&2 curl -N "http://localhost:${PORT}/foo_50" -o data2 \ -H 'Tranfer-encoding: chunked'