simon/tiny_httpd
1
0
Fork 0
mirror of https://github.com/c-cube/tiny_httpd.git synced 2025-12-06 03:05:29 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Revert "use bigstring and map_file"

Browse source 
This reverts commit 3067120539.
This commit is contained in:
craff 2021-12-19 00:54:17 -10:00
parent f08406c1ae
commit 6dceabdd6c
7 changed files with 54 additions and 118 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

79
src/Tiny_httpd.ml
View file

@ -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 "<bigstring>"
| Stream _ -> Format.pp_print_string out "<stream>"
| Void -> ()
| `String s -> Format.fprintf out "%S" s
| `Stream _ -> Format.pp_print_string out "<stream>"
| `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

15
src/Tiny_httpd.mli
View file

@ -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 ->

43
src/Tiny_httpd_dir.ml
View file

@ -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

1
src/Tiny_httpd_dir.mli
View file

@ -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;

23
src/camlzip/Tiny_httpd_camlzip.ml
View file

@ -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

2
src/dune
View file

@ -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))

9
tests/download_chunked.sh
View file

@ -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'