diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index ad416b99..258fdb0f 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -107,6 +107,7 @@ 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); @@ -116,6 +117,29 @@ 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 @@ -591,7 +615,9 @@ end *) module Response = struct - type body = [`String of string | `Stream of byte_stream | `Void] + type body = + | String of string | BigString of Bigstring.t + | Stream of byte_stream | Void type t = { code: Response_code.t; headers: Headers.t; @@ -609,15 +635,22 @@ module Response = struct let headers = Headers.set "Content-Length" (string_of_int (String.length body)) headers in - { code; headers; body=`String body; } + { 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; } 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 @@ -628,9 +661,10 @@ 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 (`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 (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 () | Error (code,msg) -> make_raw ?headers ~code msg let fail ?headers ~code fmt = @@ -640,9 +674,10 @@ module Response = struct let pp out self : unit = let pp_body out = function - | `String s -> Format.fprintf out "%S" s - | `Stream _ -> Format.pp_print_string out "" - | `Void -> () + | String s -> Format.fprintf out "%S" s + | BigString _ -> Format.pp_print_string out "" + | 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 @@ -666,12 +701,16 @@ 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 - | `String _ as b -> b, false - | `Stream _ as b -> b, true - | `Void as b -> b, false + 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 in let headers = if is_chunked then ( @@ -682,13 +721,15 @@ 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; - | `Stream str -> output_stream_chunked_ oc str; + | 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; end; flush oc end diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index 539f440c..aab4b806 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -141,6 +141,9 @@ 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 *) @@ -331,7 +334,9 @@ end the client to answer a {!Request.t}*) module Response : sig - type body = [`String of string | `Stream of byte_stream | `Void] + type body = + | String of string | BigString of Bigstring.t + | 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). *) @@ -370,6 +375,14 @@ 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 55b70d3a..c471d25c 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -7,7 +7,6 @@ type dir_behavior = type config = { mutable download: bool; - mutable mem_cache: bool; mutable dir_behavior: dir_behavior; mutable delete: bool; mutable upload: bool; @@ -16,7 +15,6 @@ type config = { let default_config () : config = { download=true - ; mem_cache=false ; dir_behavior=Forbidden ; delete=false ; upload=false @@ -43,7 +41,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] = '.' @@ -164,30 +162,24 @@ 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 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 = + 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 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 (Lazy.force mtime) then ( - S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime)); + ) 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); 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); @@ -206,13 +198,15 @@ 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", Lazy.force mtime] + ~headers:[header_html; "ETag", mtime_str] (Ok body) | Forbidden -> S.Response.make_raw ~code:405 "listing dir not allowed" ) else ( try - let ic = open_in full_path in + let bs = Bigstring_unix.with_map_file ~flags:[Open_rdonly] full_path + (fun s -> s) + in let mime_type = if Filename.extension full_path = ".css" then ( ["Content-Type", "text/css"] @@ -226,14 +220,11 @@ let add_dir_path ~config ~dir ~prefix server = with _ -> []) with _ -> [] in - S.Response.make_raw_stream - ~headers:(mime_type@["Etag", Lazy.force mtime]) - ~code:200 (S.Byte_stream.of_chan ic) + S.Response.make_raw_big + ~headers:(mime_type@["Etag", mtime_str]) + ~code:200 bs 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 57e6dcb2..a5cbf213 100644 --- a/src/Tiny_httpd_dir.mli +++ b/src/Tiny_httpd_dir.mli @@ -4,7 +4,6 @@ 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 f9a394fc..7bf53f5a 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,15 +188,27 @@ let compress_resp_stream_ in resp |> S.Response.update_headers update_headers - |> S.Response.set_body (`Stream body) + |> S.Response.set_body (Stream body) - | `Stream str -> + | 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 -> 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 _ | `Void -> resp + | String _ | BigString _ | Void -> resp ) else resp let middleware @@ -215,4 +227,3 @@ 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 29a2fb12..40391f32 100644 --- a/src/dune +++ b/src/dune @@ -2,6 +2,6 @@ (library (name tiny_httpd) (public_name tiny_httpd) - (libraries threads) + (libraries threads bigstring bigstring-unix) (flags :standard -safe-string -warn-error -a+8) (wrapped false)) diff --git a/tests/download_chunked.sh b/tests/download_chunked.sh index 2fc4e3c5..ca70f77b 100755 --- a/tests/download_chunked.sh +++ b/tests/download_chunked.sh @@ -7,6 +7,15 @@ 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'