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

Merge branch 'master' into client-ip

Browse source
This commit is contained in:
Simon Cruanes 2023-08-08 13:03:40 -04:00 • committed by GitHub
commit 1e50abb44f
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
17 changed files with 72 additions and 558 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.github/workflows/main5.yml vendored
View file

@ -33,7 +33,7 @@ jobs:
- run: opam install . --deps-only --with-test
- run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio
- run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip
- run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd
if: ${{ matrix.os == 'ubuntu-latest' }}

2
echo_eio.sh
View file

@ -1,2 +0,0 @@
#!/bin/sh
exec dune exec --display=quiet --profile=release "examples/echo_eio.exe" -- $@

7
examples/dune
View file

@ -14,13 +14,6 @@
(modules echo vfs)
(libraries tiny_httpd tiny_httpd_camlzip))
(executable
(name echo_eio)
(flags :standard -warn-error -a+8)
(modules echo_eio)
(libraries tiny_httpd tiny_httpd_camlzip
tiny_httpd_eio eio eio_posix))
(executable
(name writer)
(flags :standard -warn-error -a+8)

246
examples/echo_eio.ml
View file

@ -1,246 +0,0 @@
module S = Tiny_httpd
module S_eio = Tiny_httpd_eio
let now_ = Unix.gettimeofday
let ( let@ ) = ( @@ )
(* util: a little middleware collecting statistics *)
let middleware_stat () : S.Middleware.t * (unit -> string) =
let n_req = ref 0 in
let total_time_ = ref 0. in
let parse_time_ = ref 0. in
let build_time_ = ref 0. in
let write_time_ = ref 0. in
let m h req ~resp =
incr n_req;
let t1 = S.Request.start_time req in
let t2 = now_ () in
h req ~resp:(fun response ->
let t3 = now_ () in
resp response;
let t4 = now_ () in
total_time_ := !total_time_ +. (t4 -. t1);
parse_time_ := !parse_time_ +. (t2 -. t1);
build_time_ := !build_time_ +. (t3 -. t2);
write_time_ := !write_time_ +. (t4 -. t3))
and get_stat () =
Printf.sprintf
"%d requests (average response time: %.3fms = %.3fms + %.3fms + %.3fms)"
!n_req
(!total_time_ /. float !n_req *. 1e3)
(!parse_time_ /. float !n_req *. 1e3)
(!build_time_ /. float !n_req *. 1e3)
(!write_time_ /. float !n_req *. 1e3)
in
m, get_stat
let alice_text =
"CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of \
sitting by her sister on the bank, and of having nothing to do: once or \
twice she had peeped into the book her sister was reading, but it had no \
pictures or conversations in it, <and what is the use of a book,> thought \
Alice <without pictures or conversations?> So she was considering in her \
own mind (as well as she could, for the hot day made her feel very sleepy \
and stupid), whether the pleasure of making a daisy-chain would be worth \
the trouble of getting up and picking the daisies, when suddenly a White \
Rabbit with pink eyes ran close by her. There was nothing so very \
remarkable in that; nor did Alice think it so very much out of the way to \
hear the Rabbit say to itself, <Oh dear! Oh dear! I shall be late!> (when \
she thought it over afterwards, it occurred to her that she ought to have \
wondered at this, but at the time it all seemed quite natural); but when \
the Rabbit actually took a watch out of its waistcoat-pocket, and looked at \
it, and then hurried on, Alice started to her feet, for it flashed across \
her mind that she had never before seen a rabbit with either a \
waistcoat-pocket, or a watch to take out of it, and burning with curiosity, \
she ran across the field after it, and fortunately was just in time to see \
it pop down a large rabbit-hole under the hedge. In another moment down \
went Alice after it, never once considering how in the world she was to get \
out again. The rabbit-hole went straight on like a tunnel for some way, and \
then dipped suddenly down, so suddenly that Alice had not a moment to think \
about stopping herself before she found herself falling down a very deep \
well. Either the well was very deep, or she fell very slowly, for she had \
plenty of time as she went down to look about her and to wonder what was \
going to happen next. First, she tried to look down and make out what she \
was coming to, but it was too dark to see anything; then she looked at the \
sides of the well, and noticed that they were filled with cupboards......"
let () =
let port_ = ref 8080 in
let j = ref 32 in
Arg.parse
(Arg.align
[
"--port", Arg.Set_int port_, " set port";
"-p", Arg.Set_int port_, " set port";
"--debug", Arg.Unit (fun () -> S._enable_debug true), " enable debug";
"-j", Arg.Set_int j, " maximum number of connections";
])
(fun _ -> raise (Arg.Bad ""))
"echo [option]*";
(* use eio *)
let@ stdenv = Eio_posix.run in
let@ sw = Eio.Switch.run in
(* create server *)
let server : S.t =
S_eio.create ~port:!port_ ~max_connections:!j
~stdenv:(stdenv :> Eio_unix.Stdenv.base)
~sw ()
in
Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16 * 1024) server;
let m_stats, get_stats = middleware_stat () in
S.add_middleware server ~stage:(`Stage 1) m_stats;
(* say hello *)
S.add_route_handler ~meth:`GET server
S.Route.(exact "hello" @/ string @/ return)
(fun name _req -> S.Response.make_string (Ok ("hello " ^ name ^ "!\n")));
(* compressed file access *)
S.add_route_handler ~meth:`GET server
S.Route.(exact "zcat" @/ string_urlencoded @/ return)
(fun path _req ->
let ic = open_in path in
let str = S.Byte_stream.of_chan ic in
let mime_type =
try
let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" path) in
try
let s = [ "Content-Type", String.trim (input_line p) ] in
ignore @@ Unix.close_process_in p;
s
with _ ->
ignore @@ Unix.close_process_in p;
[]
with _ -> []
in
S.Response.make_stream ~headers:mime_type (Ok str));
(* echo request *)
S.add_route_handler server
S.Route.(exact "echo" @/ return)
(fun req ->
let q =
S.Request.query req
|> List.map (fun (k, v) -> Printf.sprintf "%S = %S" k v)
|> String.concat ";"
in
S.Response.make_string
(Ok (Format.asprintf "echo:@ %a@ (query: %s)@." S.Request.pp req q)));
(* file upload *)
S.add_route_handler_stream ~meth:`PUT server
S.Route.(exact "upload" @/ string @/ return)
(fun path req ->
S._debug (fun k ->
k "start upload %S, headers:\n%s\n\n%!" path
(Format.asprintf "%a" S.Headers.pp (S.Request.headers req)));
try
let oc = open_out @@ "/tmp/" ^ path in
S.Byte_stream.to_chan oc req.S.Request.body;
flush oc;
S.Response.make_string (Ok "uploaded file")
with e ->
S.Response.fail ~code:500 "couldn't upload file: %s"
(Printexc.to_string e));
(* stats *)
S.add_route_handler server
S.Route.(exact "stats" @/ return)
(fun _req ->
let stats = get_stats () in
S.Response.make_string @@ Ok stats);
S.add_route_handler server ~meth:`POST
S.Route.(exact "quit" @/ return)
(fun _req ->
S.stop server;
S.Response.make_string (Ok "quitting"));
S.add_route_handler server
S.Route.(exact "alice" @/ return)
(fun _req -> S.Response.make_string (Ok alice_text));
(* main page *)
S.add_route_handler server
S.Route.(return)
(fun _req ->
let open Tiny_httpd_html in
let h =
html []
[
head [] [ title [] [ txt "index of echo" ] ];
body []
[
h3 [] [ txt "welcome!" ];
p [] [ b [] [ txt "endpoints are:" ] ];
ul []
[
li [] [ pre [] [ txt "/hello/:name (GET)" ] ];
li []
[
pre []
[
a [ A.href "/echo/" ] [ txt "echo" ];
txt " echo back query";
];
];
li []
[ pre [] [ txt "/upload/:path (PUT) to upload a file" ] ];
li []
[
pre []
[
txt
"/zcat/:path (GET) to download a file (deflate \
transfer-encoding)";
];
];
li []
[
pre []
[
a [ A.href "/stats/" ] [ txt "/stats/" ];
txt " (GET) to access statistics";
];
];
li []
[
pre []
[
a [ A.href "/vfs/" ] [ txt "/vfs" ];
txt " (GET) to access a VFS embedded in the binary";
];
];
li []
[
pre
[ A.style "display: inline" ]
[
a [ A.href "/quit" ] [ txt "/quit" ];
txt " (POST) to stop server";
];
form
[
A.style "display: inline";
A.action "/quit";
A.method_ "POST";
]
[ button [ A.type_ "submit" ] [ txt "quit" ] ];
];
];
];
]
in
let s = to_string_top h in
S.Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok s);
Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
let res = S.run server in
Gc.print_stat stdout;
match res with
| Ok () -> ()
| Error e -> raise e

4
src/Tiny_httpd_html.ml
View file

@ -16,7 +16,7 @@ include Tiny_httpd_html_
be a "html" tag.
@since NEXT_RELEASE
*)
let to_out_channel ?(top = false) (self : elt) (out : IO.Out_channel.t) : unit =
let to_out_channel ?(top = false) (self : elt) (out : IO.Output.t) : unit =
let out = Out.create_of_out out in
if top then Out.add_string out "<!DOCTYPE html>\n";
self out;
@ -28,7 +28,7 @@ let to_out_channel ?(top = false) (self : elt) (out : IO.Out_channel.t) : unit =
be a "html" tag. *)
let to_string ?top (self : elt) : string =
let buf = Buffer.create 64 in
let out = IO.Out_channel.of_buffer buf in
let out = IO.Output.of_buffer buf in
to_out_channel ?top self out;
Buffer.contents buf

15
src/Tiny_httpd_io.ml
View file

@ -11,7 +11,7 @@
module Buf = Tiny_httpd_buf
(** Input channel (byte source) *)
module In_channel = struct
module Input = struct
type t = {
input: bytes -> int -> int -> int;
(** Read into the slice. Returns [0] only if the
@ -54,7 +54,7 @@ module In_channel = struct
end
(** Output channel (byte sink) *)
module Out_channel = struct
module Output = struct
type t = {
output_char: char -> unit; (** Output a single char *)
output: bytes -> int -> int -> unit; (** Output slice *)
@ -65,7 +65,7 @@ module Out_channel = struct
This can be a [Buffer.t], an [out_channel], a [Unix.file_descr], etc. *)
(** [of_out_channel oc] wraps the channel into a {!Out_channel.t}.
(** [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] *)
let of_out_channel ?(close_noerr = false) (oc : out_channel) : t =
@ -158,7 +158,7 @@ end
(** A writer abstraction. *)
module Writer = struct
type t = { write: Out_channel.t -> unit } [@@unboxed]
type t = { write: Output.t -> unit } [@@unboxed]
(** Writer.
A writer is a push-based stream of bytes.
@ -173,22 +173,21 @@ module Writer = struct
let[@inline] make ~write () : t = { write }
(** Write into the channel. *)
let[@inline] write (oc : Out_channel.t) (self : t) : unit = self.write oc
let[@inline] write (oc : Output.t) (self : t) : unit = self.write oc
(** Empty writer, will output 0 bytes. *)
let empty : t = { write = ignore }
(** A writer that just emits the bytes from the given string. *)
let[@inline] of_string (str : string) : t =
let write oc = Out_channel.output_string oc str in
let write oc = Output.output_string oc str in
{ write }
end
(** A TCP server abstraction. *)
module TCP_server = struct
type conn_handler = {
handle: ?client_addr:Unix.sockaddr -> In_channel.t -> Out_channel.t -> unit;
(** Handle client connection *)
handle: ?client_addr:Unix.sockaddr -> Input.t -> Output.t -> unit; (** Handle client connection *)
}
type t = {

55
src/Tiny_httpd_server.ml
View file

@ -407,27 +407,27 @@ module Response = struct
else
make_raw ~headers ~code "" (* invalid to not have a body *)
let make_string ?headers r =
let make_string ?headers ?(code = 200) r =
match r with
| Ok body -> make_raw ?headers ~code:200 body
| Ok body -> make_raw ?headers ~code body
| Error (code, msg) -> make_raw ?headers ~code msg
let make_stream ?headers r =
let make_stream ?headers ?(code = 200) r =
match r with
| Ok body -> make_raw_stream ?headers ~code:200 body
| Ok body -> make_raw_stream ?headers ~code body
| Error (code, msg) -> make_raw ?headers ~code msg
let make_writer ?headers r : t =
let make_writer ?headers ?(code = 200) r : t =
match r with
| Ok body -> make_raw_writer ?headers ~code:200 body
| Ok body -> make_raw_writer ?headers ~code body
| Error (code, msg) -> make_raw ?headers ~code msg
let make ?headers r : t =
let make ?headers ?(code = 200) 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 (`Writer f) -> make_raw_writer ?headers ~code:200 f
| Ok (`String body) -> make_raw ?headers ~code body
| Ok (`Stream body) -> make_raw_stream ?headers ~code body
| Ok `Void -> make_void ?headers ~code ()
| Ok (`Writer f) -> make_raw_writer ?headers ~code f
| Error (code, msg) -> make_raw ?headers ~code msg
let fail ?headers ~code fmt =
@ -446,7 +446,7 @@ module Response = struct
Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" self.code
Headers.pp self.headers pp_body self.body
let output_ ~buf (oc : IO.Out_channel.t) (self : t) : unit =
let output_ ~buf (oc : IO.Output.t) (self : t) : unit =
(* double indirection:
- print into [buffer] using [bprintf]
- transfer to [buf_] so we can output from there *)
@ -490,21 +490,21 @@ module Response = struct
Buffer.clear tmp_buffer)
headers;
IO.Out_channel.output_buf oc buf;
IO.Out_channel.output_string oc "\r\n";
IO.Output.output_buf oc buf;
IO.Output.output_string oc "\r\n";
Buf.clear buf;
(match body with
| `String "" | `Void -> ()
| `String s -> IO.Out_channel.output_string oc s
| `String s -> IO.Output.output_string oc s
| `Writer w ->
(* use buffer to chunk encode [w] *)
let oc' = IO.Out_channel.chunk_encoding ~buf ~close_rec:false oc in
let oc' = IO.Output.chunk_encoding ~buf ~close_rec:false oc in
(try
IO.Writer.write oc' w;
IO.Out_channel.close oc'
IO.Output.close oc'
with e ->
IO.Out_channel.close oc';
IO.Output.close oc';
raise e)
| `Stream str ->
(try
@ -513,7 +513,7 @@ module Response = struct
with e ->
Byte_stream.close str;
raise e));
IO.Out_channel.flush oc
IO.Output.flush oc
end
(* semaphore, for limiting concurrency. *)
@ -647,7 +647,7 @@ module Middleware = struct
end
(* a request handler. handles a single request. *)
type cb_path_handler = IO.Out_channel.t -> Middleware.handler
type cb_path_handler = IO.Output.t -> Middleware.handler
module type SERVER_SENT_GENERATOR = sig
val set_headers : Headers.t -> unit
@ -795,7 +795,7 @@ let[@inline] _opt_iter ~f o =
exception Exit_SSE
let add_route_server_sent_handler ?accept self route f =
let tr_req (oc : IO.Out_channel.t) req ~resp f =
let tr_req (oc : IO.Output.t) req ~resp f =
let req =
Pool.with_resource self.buf_pool @@ fun buf ->
Request.read_body_full ~buf req
@ -818,7 +818,7 @@ let add_route_server_sent_handler ?accept self route f =
in
let[@inline] writef fmt =
Printf.ksprintf (IO.Out_channel.output_string oc) fmt
Printf.ksprintf (IO.Output.output_string oc) fmt
in
let send_event ?event ?id ?retry ~data () : unit =
@ -828,9 +828,9 @@ let add_route_server_sent_handler ?accept self route f =
_opt_iter retry ~f:(fun e -> writef "retry: %s\n" e);
let l = String.split_on_char '\n' data in
List.iter (fun s -> writef "data: %s\n" s) l;
IO.Out_channel.output_string oc "\n";
IO.Output.output_string oc "\n";
(* finish group *)
IO.Out_channel.flush oc
IO.Output.flush oc
in
let module SSG = struct
let set_headers h =
@ -843,7 +843,7 @@ let add_route_server_sent_handler ?accept self route f =
let close () = raise Exit_SSE
end in
try f req (module SSG : SERVER_SENT_GENERATOR)
with Exit_SSE -> IO.Out_channel.close oc
with Exit_SSE -> IO.Output.close oc
in
add_route_handler_ self ?accept ~meth:`GET route ~tr_req f
@ -940,10 +940,9 @@ module Unix_tcp_server_ = struct
Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout);
Unix.(setsockopt_float client_sock SO_SNDTIMEO self.timeout);
let oc =
IO.Out_channel.of_out_channel
@@ Unix.out_channel_of_descr client_sock
IO.Output.of_out_channel @@ Unix.out_channel_of_descr client_sock
in
let ic = IO.In_channel.of_unix_fd client_sock in
let ic = IO.Input.of_unix_fd client_sock in
handle.handle ~client_addr ic oc;
_debug (fun k -> k "done with client, exiting");
(try Unix.close client_sock

17
src/Tiny_httpd_server.mli
View file

@ -252,7 +252,11 @@ module Response : sig
(** Return a response without a body at all.
@since 0.13 *)
val make : ?headers:Headers.t -> (body, Response_code.t * string) result -> t
val make :
?headers:Headers.t ->
?code:int ->
(body, Response_code.t * string) result ->
t
(** [make r] turns a result into a response.
- [make (Ok body)] replies with [200] and the body.
@ -261,17 +265,24 @@ module Response : sig
*)
val make_string :
?headers:Headers.t -> (string, Response_code.t * string) result -> t
?headers:Headers.t ->
?code:int ->
(string, Response_code.t * string) result ->
t
(** Same as {!make} but with a string body. *)
val make_writer :
?headers:Headers.t ->
?code:int ->
(Tiny_httpd_io.Writer.t, Response_code.t * string) result ->
t
(** Same as {!make} but with a writer body. *)
val make_stream :
?headers:Headers.t -> (byte_stream, Response_code.t * string) result -> t
?headers:Headers.t ->
?code:int ->
(byte_stream, Response_code.t * string) result ->
t
(** Same as {!make} but with a stream body. *)
val fail :

22
src/Tiny_httpd_stream.ml
View file

@ -46,28 +46,28 @@ let make ?(bs = Bytes.create @@ (16 * 1024)) ?(close = ignore) ~consume ~fill ()
in
self
let of_input ?(buf_size = 16 * 1024) (ic : IO.In_channel.t) : t =
let of_input ?(buf_size = 16 * 1024) (ic : IO.Input.t) : t =
make ~bs:(Bytes.create buf_size)
~close:(fun _ -> IO.In_channel.close ic)
~close:(fun _ -> IO.Input.close ic)
~consume:(fun self n ->
self.off <- self.off + n;
self.len <- self.len - n)
~fill:(fun self ->
if self.off >= self.len then (
self.off <- 0;
self.len <- IO.In_channel.input ic self.bs 0 (Bytes.length self.bs)
self.len <- IO.Input.input ic self.bs 0 (Bytes.length self.bs)
))
()
let of_chan_ ?buf_size ic ~close_noerr : t =
let inc = IO.In_channel.of_in_channel ~close_noerr ic in
let inc = IO.Input.of_in_channel ~close_noerr ic in
of_input ?buf_size inc
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.In_channel.of_unix_fd ~close_noerr ic in
let inc = IO.Input.of_unix_fd ~close_noerr ic in
of_input ?buf_size inc
let of_fd ?buf_size fd : t = of_fd_ ?buf_size ~close_noerr:false fd
@ -84,9 +84,7 @@ let rec iter f (self : t) : unit =
)
let to_chan (oc : out_channel) (self : t) = iter (output oc) self
let to_chan' (oc : IO.Out_channel.t) (self : t) =
iter (IO.Out_channel.output oc) self
let to_chan' (oc : IO.Output.t) (self : t) = iter (IO.Output.output oc) self
let to_writer (self : t) : Tiny_httpd_io.Writer.t =
{ write = (fun oc -> to_chan' oc self) }
@ -299,11 +297,11 @@ let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
refill := false)
()
let output_chunked' ?buf (oc : IO.Out_channel.t) (self : t) : unit =
let oc' = IO.Out_channel.chunk_encoding ?buf oc ~close_rec:false in
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.Out_channel.close oc'
IO.Output.close oc'
(* print a stream as a series of chunks *)
let output_chunked ?buf (oc : out_channel) (self : t) : unit =
output_chunked' ?buf (IO.Out_channel.of_out_channel oc) self
output_chunked' ?buf (IO.Output.of_out_channel oc) self

6
src/Tiny_httpd_stream.mli
View file

@ -64,7 +64,7 @@ val close : t -> unit
val empty : t
(** Stream with 0 bytes inside *)
val of_input : ?buf_size:int -> Tiny_httpd_io.In_channel.t -> t
val of_input : ?buf_size:int -> Tiny_httpd_io.Input.t -> t
(** Make a buffered stream from the given channel.
@since NEXT_RELEASE *)
@ -94,7 +94,7 @@ val to_chan : out_channel -> t -> unit
(** Write the stream to the channel.
@since 0.3 *)
val to_chan' : Tiny_httpd_io.Out_channel.t -> t -> unit
val to_chan' : Tiny_httpd_io.Output.t -> t -> unit
(** Write to the IO channel.
@since NEXT_RELEASE *)
@ -154,6 +154,6 @@ val output_chunked : ?buf:Tiny_httpd_buf.t -> out_channel -> t -> unit
@param buf optional buffer for chunking (since NEXT_RELEASE) *)
val output_chunked' :
?buf:Tiny_httpd_buf.t -> Tiny_httpd_io.Out_channel.t -> t -> unit
?buf:Tiny_httpd_buf.t -> Tiny_httpd_io.Output.t -> t -> unit
(** Write the stream into the channel, using the chunked encoding.
@since NEXT_RELEASE *)

2
src/camlzip/Tiny_httpd_camlzip.ml
View file

@ -1,7 +1,7 @@
module S = Tiny_httpd_server
module BS = Tiny_httpd_stream
module W = Tiny_httpd_io.Writer
module Out = Tiny_httpd_io.Out_channel
module Out = Tiny_httpd_io.Output
let decode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream =
S._debug (fun k -> k "wrap stream with deflate.decode");

2
src/dune
View file

@ -1,7 +1,7 @@
(env
(_
(flags :standard -warn-error -a+8 -w +a-4-32-40-42-44-70 -color always -safe-string
(flags :standard -warn-error -a+8 -w +a-4-32-40-42-44-48-70 -color always -safe-string
-strict-sequence)))
(library

8
src/eio/dune
View file

@ -1,8 +0,0 @@
(library
(name tiny_httpd_eio)
(public_name tiny_httpd_eio)
(synopsis "An EIO-based backend for Tiny_httpd")
(flags :standard -safe-string -warn-error -a+8)
(libraries tiny_httpd eio eio.unix))

178
src/eio/tiny_httpd_eio.ml
View file

@ -1,178 +0,0 @@
module IO = Tiny_httpd_io
module H = Tiny_httpd_server
module Pool = Tiny_httpd_pool
let ( let@ ) = ( @@ )
type 'a with_args =
?addr:string ->
?port:int ->
?max_connections:int ->
stdenv:Eio_unix.Stdenv.base ->
sw:Eio.Switch.t ->
'a
let get_max_connection_ ?(max_connections = 64) () : int =
let max_connections = max 4 max_connections in
max_connections
let buf_size = 16 * 1024
let ic_of_flow ~buf_pool:ic_pool (flow : Eio.Net.stream_socket) :
IO.In_channel.t =
Pool.with_resource ic_pool @@ fun cstruct ->
let len_slice = ref 0 in
let offset = ref 0 in
let input buf i len =
if len = 0 then
0
else (
let available = ref (!len_slice - !offset) in
if !available = 0 then (
let n = flow#read_into cstruct in
offset := 0;
len_slice := n;
available := n
);
let n = min !available len in
if n > 0 then (
Cstruct.blit_to_bytes cstruct !offset buf i n;
offset := !offset + n;
n
) else
0
)
in
let close () = flow#shutdown `Receive in
{ IO.In_channel.input; close }
let oc_of_flow ~buf_pool:oc_pool (flow : Eio.Net.stream_socket) :
IO.Out_channel.t =
(* write buffer *)
Pool.with_resource oc_pool @@ fun wbuf ->
let offset = ref 0 in
let flush () =
if !offset > 0 then (
let i = ref 0 in
let len = ref !offset in
let src =
object
inherit Eio.Flow.source
method read_into (cstruct : Cstruct.t) : int =
if !len = 0 then raise End_of_file;
let n = min !len (Cstruct.length cstruct) in
Cstruct.blit_from_bytes wbuf !i cstruct 0 n;
i := !i + n;
len := !len - n;
n
end
in
flow#copy src;
offset := 0
)
in
let output buf i len =
let i = ref i in
let len = ref len in
while !len > 0 do
let available = Bytes.length wbuf - !offset in
let n = min !len available in
Bytes.blit buf !i wbuf !offset n;
offset := !offset + n;
i := !i + n;
len := !len - n;
if !offset = Bytes.length wbuf then flush ()
done
in
let output_char c =
if !offset = Bytes.length wbuf then flush ();
Bytes.set wbuf !offset c;
incr offset;
if !offset = Bytes.length wbuf then flush ()
in
let close () = flow#shutdown `Send in
{ IO.Out_channel.close; flush; output; output_char }
let io_backend ?(addr = "127.0.0.1") ?(port = 8080) ?max_connections
~(stdenv : Eio_unix.Stdenv.base) ~(sw : Eio.Switch.t) () :
(module H.IO_BACKEND) =
let module M = struct
let init_addr () = addr
let init_port () = port
let get_time_s () = Unix.gettimeofday ()
let ic_pool = Pool.create ~mk_item:(fun () -> Cstruct.create buf_size) ()
let oc_pool = Pool.create ~mk_item:(fun () -> Bytes.create buf_size) ()
let tcp_server () : IO.TCP_server.builder =
{
IO.TCP_server.serve =
(fun ~after_init ~handle () : unit ->
(* FIXME: parse *)
let ip_addr = Eio.Net.Ipaddr.V4.any in
let running = Atomic.make true in
let active_conns = Atomic.make 0 in
Eio.Switch.on_release sw (fun () -> Atomic.set running false);
let net = Eio.Stdenv.net stdenv in
(* main server socket *)
let sock =
let backlog = get_max_connection_ ?max_connections () in
Eio.Net.listen ~reuse_addr:true ~reuse_port:true ~backlog ~sw net
(`Tcp (ip_addr, port))
in
let tcp_server : IO.TCP_server.t =
{
running = (fun () -> Atomic.get running);
stop =
(fun () ->
Atomic.set running false;
Eio.Switch.fail sw Exit);
endpoint =
(fun () ->
(* TODO: find the real port *)
addr, port);
active_connections = (fun () -> Atomic.get active_conns);
}
in
after_init tcp_server;
while Atomic.get running do
Eio.Net.accept_fork ~sw
~on_error:(fun exn ->
H._debug (fun k ->
k "error in client handler: %s" (Printexc.to_string exn)))
sock
(fun flow _client_addr ->
Atomic.incr active_conns;
let@ () =
Fun.protect ~finally:(fun () ->
H._debug (fun k ->
k "Tiny_httpd_eio: client handler returned");
Atomic.decr active_conns)
in
let ic = ic_of_flow ~buf_pool:ic_pool flow in
let oc = oc_of_flow ~buf_pool:oc_pool flow in
handle.handle ic oc)
done);
}
end in
(module M)
let create ?addr ?port ?max_connections ~stdenv ~sw ?buf_size ?middlewares () :
H.t =
let backend = io_backend ?addr ?port ?max_connections ~stdenv ~sw () in
H.create_from ?buf_size ?middlewares ~backend ()

30
src/eio/tiny_httpd_eio.mli
View file

@ -1,30 +0,0 @@
(** Tiny httpd EIO backend.
This replaces the threads + Unix blocking syscalls of {!Tiny_httpd_server}
with an Eio-based cooperative system.
{b NOTE}: this is very experimental and will absolutely change over time,
especially since Eio itself is also subject to change.
@since NEXT_RELEASE *)
(* TODO: pass in a switch *)
type 'a with_args =
?addr:string ->
?port:int ->
?max_connections:int ->
stdenv:Eio_unix.Stdenv.base ->
sw:Eio.Switch.t ->
'a
val io_backend : (unit -> (module Tiny_httpd_server.IO_BACKEND)) with_args
(** Create a server *)
val create :
(?buf_size:int ->
?middlewares:
([ `Encoding | `Stage of int ] * Tiny_httpd_server.Middleware.t) list ->
unit ->
Tiny_httpd_server.t)
with_args
(** Create a server *)

12
src/gen/gentags.ml
View file

@ -294,7 +294,7 @@ let prelude =
module Out : sig
type t
val create_of_buffer : Buffer.t -> t
val create_of_out: Tiny_httpd_io.Out_channel.t -> t
val create_of_out: Tiny_httpd_io.Output.t -> t
val flush : t -> unit
val add_char : t -> char -> unit
val add_string : t -> string -> unit
@ -303,14 +303,14 @@ module Out : sig
end = struct
module IO = Tiny_httpd_io
type t = {
out: IO.Out_channel.t;
out: IO.Output.t;
mutable fmt_nl: bool; (* if true, we print [\n] around tags to format the html *)
}
let create_of_out out = {out; fmt_nl=true}
let create_of_buffer buf : t = create_of_out (IO.Out_channel.of_buffer buf)
let[@inline] flush self : unit = IO.Out_channel.flush self.out
let[@inline] add_char self c = IO.Out_channel.output_char self.out c
let[@inline] add_string self s = IO.Out_channel.output_string self.out s
let create_of_buffer buf : t = create_of_out (IO.Output.of_buffer buf)
let[@inline] flush self : unit = IO.Output.flush self.out
let[@inline] add_char self c = IO.Output.output_char self.out c
let[@inline] add_string self s = IO.Output.output_string self.out s
let[@inline] add_format_nl self = if self.fmt_nl then add_char self '\n'
let with_no_format_nl self f =
if self.fmt_nl then (

22
tiny_httpd_eio.opam
View file

@ -1,22 +0,0 @@
opam-version: "2.0"
version: "0.13"
authors: ["Simon Cruanes"]
maintainer: "simon.cruanes.2007@m4x.org"
license: "MIT"
synopsis: "Run tiny_httpd on Eio"
build: [
["dune" "build" "@install" "-p" name "-j" jobs]
["dune" "build" "@doc" "-p" name] {with-doc}
["dune" "runtest" "-p" name] {with-test}
]
depends: [
"dune" { >= "2.0" }
"eio" {>= "0.9"}
"tiny_httpd" { = version }
"odoc" {with-doc}
]
tags: [ "http" "server" "eio" ]
homepage: "https://github.com/c-cube/tiny_httpd/"
doc: "https://c-cube.github.io/tiny_httpd/"
bug-reports: "https://github.com/c-cube/tiny_httpd/issues"
dev-repo: "git+https://github.com/c-cube/tiny_httpd.git"