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

use bigstring and map_file

Browse source
This commit is contained in:
craff 2021-12-19 00:29:56 -10:00
parent 0a31d09601
commit 3067120539
7 changed files with 118 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

79
src/Tiny_httpd.ml
View file

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

15
src/Tiny_httpd.mli
View file

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

43
src/Tiny_httpd_dir.ml
View file

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

1
src/Tiny_httpd_dir.mli
View file

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

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

2
src/dune
View file

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

9
tests/download_chunked.sh
View file

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