simon/tiny_httpd
1
0
Fork 0
mirror of https://github.com/c-cube/tiny_httpd.git synced 2026-01-21 16:56:40 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge pull request #81 from c-cube/refactor-and-use-hmap

Browse source 
Refactor, modularize, add hmap to requests
This commit is contained in:
Simon Cruanes 2024-03-06 21:26:25 -05:00 • committed by GitHub
commit cced01e343
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
79 changed files with 2970 additions and 2869 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
.gitmodules vendored Normal file
View file

@ -0,0 +1,3 @@
[submodule "vendor/iostream"]
path = vendor/iostream
url = https://github.com/c-cube/ocaml-iostream

3
dune-project
View file

@ -21,6 +21,8 @@
seq
base-threads
result
hmap
(iostream (>= 0.2))
(ocaml (>= 4.08))
(odoc :with-doc)
(logs :with-test)
@ -34,5 +36,6 @@
(depends
(tiny_httpd (= :version))
(camlzip (>= 1.06))
iostream-camlzip
(logs :with-test)
(odoc :with-doc)))

93
examples/echo.ml
View file

@ -1,4 +1,4 @@
module S = Tiny_httpd
open Tiny_httpd_core
module Log = Tiny_httpd.Log
let now_ = Unix.gettimeofday
@ -34,7 +34,7 @@ let alice_text =
sides of the well, and noticed that they were filled with cupboards......"
(* util: a little middleware collecting statistics *)
let middleware_stat () : S.Middleware.t * (unit -> string) =
let middleware_stat () : Server.Middleware.t * (unit -> string) =
let n_req = ref 0 in
let total_time_ = ref 0. in
let parse_time_ = ref 0. in
@ -43,7 +43,7 @@ let middleware_stat () : S.Middleware.t * (unit -> string) =
let m h req ~resp =
incr n_req;
let t1 = S.Request.start_time req in
let t1 = Request.start_time req in
let t2 = now_ () in
h req ~resp:(fun response ->
let t3 = now_ () in
@ -92,23 +92,23 @@ let () =
(fun _ -> raise (Arg.Bad ""))
"echo [option]*";
let server = S.create ~port:!port_ ~max_connections:!j () in
let server = Tiny_httpd.create ~port:!port_ ~max_connections:!j () 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;
Server.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")));
Server.add_route_handler ~meth:`GET server
Route.(exact "hello" @/ string @/ return)
(fun name _req -> Response.make_string (Ok ("hello " ^ name ^ "!\n")));
(* compressed file access *)
S.add_route_handler ~meth:`GET server
S.Route.(exact "zcat" @/ string_urlencoded @/ return)
Server.add_route_handler ~meth:`GET server
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 str = IO.Input.of_in_channel ic in
let mime_type =
try
let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" path) in
@ -121,42 +121,42 @@ let () =
[]
with _ -> []
in
S.Response.make_stream ~headers:mime_type (Ok str));
Response.make_stream ~headers:mime_type (Ok str));
(* echo request *)
S.add_route_handler server
S.Route.(exact "echo" @/ return)
Server.add_route_handler server
Route.(exact "echo" @/ return)
(fun req ->
let q =
S.Request.query req
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)));
Response.make_string
(Ok (Format.asprintf "echo:@ %a@ (query: %s)@." Request.pp req q)));
(* file upload *)
S.add_route_handler_stream ~meth:`PUT server
S.Route.(exact "upload" @/ string @/ return)
Server.add_route_handler_stream ~meth:`PUT server
Route.(exact "upload" @/ string @/ return)
(fun path req ->
Log.debug (fun k ->
k "start upload %S, headers:\n%s\n\n%!" path
(Format.asprintf "%a" S.Headers.pp (S.Request.headers req)));
(Format.asprintf "%a" Headers.pp (Request.headers req)));
try
let oc = open_out @@ "/tmp/" ^ path in
S.Byte_stream.to_chan oc req.S.Request.body;
IO.Input.to_chan oc req.Request.body;
flush oc;
S.Response.make_string (Ok "uploaded file")
Response.make_string (Ok "uploaded file")
with e ->
S.Response.fail ~code:500 "couldn't upload file: %s"
Response.fail ~code:500 "couldn't upload file: %s"
(Printexc.to_string e));
(* protected by login *)
S.add_route_handler server
S.Route.(exact "protected" @/ return)
Server.add_route_handler server
Route.(exact "protected" @/ return)
(fun req ->
let ok =
match S.Request.get_header req "authorization" with
match Request.get_header req "authorization" with
| Some v ->
Log.debug (fun k -> k "authenticate with %S" v);
v = "Basic " ^ base64 "user:foobar"
@ -167,40 +167,40 @@ let () =
let s =
"<p>hello, this is super secret!</p><a href=\"/logout\">log out</a>"
in
S.Response.make_string (Ok s)
Response.make_string (Ok s)
) else (
let headers =
S.Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"")
Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"")
in
S.Response.fail ~code:401 ~headers "invalid"
Response.fail ~code:401 ~headers "invalid"
));
(* logout *)
S.add_route_handler server
S.Route.(exact "logout" @/ return)
(fun _req -> S.Response.fail ~code:401 "logged out");
Server.add_route_handler server
Route.(exact "logout" @/ return)
(fun _req -> Response.fail ~code:401 "logged out");
(* stats *)
S.add_route_handler server
S.Route.(exact "stats" @/ return)
Server.add_route_handler server
Route.(exact "stats" @/ return)
(fun _req ->
let stats = get_stats () in
S.Response.make_string @@ Ok stats);
Response.make_string @@ Ok stats);
S.add_route_handler server
S.Route.(exact "alice" @/ return)
(fun _req -> S.Response.make_string (Ok alice_text));
Server.add_route_handler server
Route.(exact "alice" @/ return)
(fun _req -> Response.make_string (Ok alice_text));
(* VFS *)
Tiny_httpd_dir.add_vfs server
Tiny_httpd.Dir.add_vfs server
~config:
(Tiny_httpd_dir.config ~download:true
~dir_behavior:Tiny_httpd_dir.Index_or_lists ())
(Tiny_httpd.Dir.config ~download:true
~dir_behavior:Tiny_httpd.Dir.Index_or_lists ())
~vfs:Vfs.vfs ~prefix:"vfs";
(* main page *)
S.add_route_handler server
S.Route.(return)
Server.add_route_handler server
Route.(return)
(fun _req ->
let open Tiny_httpd_html in
let h =
@ -272,9 +272,10 @@ let () =
]
in
let s = to_string_top h in
S.Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok 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);
match S.run server with
Printf.printf "listening on http://%s:%d\n%!" (Server.addr server)
(Server.port server);
match Server.run server with
| Ok () -> ()
| Error e -> raise e

8
examples/echo_ws.ml
View file

@ -1,6 +1,5 @@
module S = Tiny_httpd
module Log = Tiny_httpd.Log
module IO = Tiny_httpd_io
open Tiny_httpd_core
let setup_logging ~debug () =
Logs.set_reporter @@ Logs.format_reporter ();
@ -13,8 +12,7 @@ let setup_logging ~debug () =
let handle_ws _client_addr ic oc =
Log.info (fun k ->
k "new client connection from %s"
(Tiny_httpd_util.show_sockaddr _client_addr));
k "new client connection from %s" (Util.show_sockaddr _client_addr));
let (_ : Thread.t) =
Thread.create
@ -58,7 +56,7 @@ let () =
let server = S.create ~port:!port_ ~max_connections:!j () in
Tiny_httpd_ws.add_route_handler server
S.Route.(exact "echo" @/ return)
Route.(exact "echo" @/ return)
handle_ws;
Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);

27
examples/sse_server.ml
View file

@ -1,7 +1,6 @@
(* serves some streams of events *)
module S = Tiny_httpd
module Log = Tiny_httpd_log
open Tiny_httpd_core
let port = ref 8080
@ -14,7 +13,7 @@ let () =
])
(fun _ -> ())
"sse_clock [opt*]";
let server = S.create ~port:!port () in
let server = Tiny_httpd.create ~port:!port () in
let extra_headers =
[
@ -24,9 +23,9 @@ let () =
in
(* tick/tock goes the clock *)
S.add_route_server_sent_handler server
S.Route.(exact "clock" @/ return)
(fun _req (module EV : S.SERVER_SENT_GENERATOR) ->
Server.add_route_server_sent_handler server
Route.(exact "clock" @/ return)
(fun _req (module EV : Server.SERVER_SENT_GENERATOR) ->
Log.debug (fun k -> k "new SSE connection");
EV.set_headers extra_headers;
let tick = ref true in
@ -47,26 +46,26 @@ let () =
done);
(* just count *)
S.add_route_server_sent_handler server
S.Route.(exact "count" @/ return)
(fun _req (module EV : S.SERVER_SENT_GENERATOR) ->
Server.add_route_server_sent_handler server
Route.(exact "count" @/ return)
(fun _req (module EV : Server.SERVER_SENT_GENERATOR) ->
let n = ref 0 in
while true do
EV.send_event ~data:(string_of_int !n) ();
incr n;
Unix.sleepf 0.1
done);
S.add_route_server_sent_handler server
S.Route.(exact "count" @/ int @/ return)
(fun n _req (module EV : S.SERVER_SENT_GENERATOR) ->
Server.add_route_server_sent_handler server
Route.(exact "count" @/ int @/ return)
(fun n _req (module EV : Server.SERVER_SENT_GENERATOR) ->
for i = 0 to n do
EV.send_event ~data:(string_of_int i) ();
Unix.sleepf 0.1
done;
EV.close ());
Printf.printf "listening on http://localhost:%d/\n%!" (S.port server);
match S.run server with
Printf.printf "listening on http://localhost:%d/\n%!" (Server.port server);
match Server.run server with
| Ok () -> ()
| Error e ->
Printf.eprintf "error: %s\n%!" (Printexc.to_string e);

13
examples/writer.ml
View file

@ -1,7 +1,8 @@
module H = Tiny_httpd
open Tiny_httpd_core
let serve_zeroes server : unit =
H.add_route_handler server H.(Route.(exact "zeroes" @/ int @/ return))
Server.add_route_handler server Route.(exact "zeroes" @/ int @/ return)
@@ fun n _req ->
(* stream [n] zeroes *)
let write (oc : H.IO.Output.t) : unit =
@ -11,7 +12,7 @@ let serve_zeroes server : unit =
done
in
let writer = H.IO.Writer.make ~write () in
H.Response.make_writer @@ Ok writer
Response.make_writer @@ Ok writer
let serve_file server : unit =
H.add_route_handler server H.(Route.(exact "file" @/ string @/ return))
@ -32,9 +33,9 @@ let serve_file server : unit =
in
let writer = H.IO.Writer.make ~write () in
H.Response.make_writer @@ Ok writer
Response.make_writer @@ Ok writer
) else
H.Response.fail ~code:404 "file not found"
Response.fail ~code:404 "file not found"
let () =
let port = ref 8085 in
@ -43,7 +44,7 @@ let () =
Printf.printf "listen on http://localhost:%d/\n%!" !port;
serve_file server;
serve_zeroes server;
H.add_route_handler server H.Route.return (fun _req ->
H.add_route_handler server Route.return (fun _req ->
let body =
H.Html.(
div []
@ -58,5 +59,5 @@ let () =
])
|> H.Html.to_string_top
in
H.Response.make_string @@ Ok body);
Response.make_string @@ Ok body);
H.run_exn server

75
src/Tiny_httpd.ml
View file

@ -1,9 +1,68 @@
module Buf = Tiny_httpd_buf
module Byte_stream = Tiny_httpd_stream
include Tiny_httpd_server
module Util = Tiny_httpd_util
module Dir = Tiny_httpd_dir
module Buf = Buf
module Html = Tiny_httpd_html
module IO = Tiny_httpd_io
module Pool = Tiny_httpd_pool
module Log = Tiny_httpd_log
module IO = Tiny_httpd_core.IO
module Request = Tiny_httpd_core.Request
module Response = Tiny_httpd_core.Response
module Response_code = Tiny_httpd_core.Response_code
module Route = Tiny_httpd_core.Route
module Headers = Tiny_httpd_core.Headers
module Meth = Tiny_httpd_core.Meth
module Pool = Tiny_httpd_core.Pool
module Log = Tiny_httpd_core.Log
module Server = Tiny_httpd_core.Server
module Util = Tiny_httpd_core.Util
include Server
module Dir = Tiny_httpd_unix.Dir
module type VFS = Tiny_httpd_unix.Dir.VFS
open struct
let get_max_connection_ ?(max_connections = 64) () : int =
let max_connections = max 4 max_connections in
max_connections
let clear_slice (slice : IO.Slice.t) =
Bytes.fill slice.bytes 0 (Bytes.length slice.bytes) '\x00';
slice.off <- 0;
slice.len <- 0
end
let create ?(masksigpipe = true) ?max_connections ?(timeout = 0.0) ?buf_size
?(get_time_s = Unix.gettimeofday)
?(new_thread = fun f -> ignore (Thread.create f () : Thread.t))
?(addr = "127.0.0.1") ?(port = 8080) ?sock ?middlewares () : t =
let max_connections = get_max_connection_ ?max_connections () in
let server =
{
Tiny_httpd_unix.Unix_tcp_server_.addr;
new_thread;
buf_pool =
Pool.create ~clear:Buf.clear_and_zero
~mk_item:(fun () -> Buf.create ?size:buf_size ())
();
slice_pool =
Pool.create ~clear:clear_slice
~mk_item:
(let buf_size = Option.value buf_size ~default:4096 in
fun () -> IO.Slice.create buf_size)
();
running = true;
port;
sock;
max_connections;
sem_max_connections = Tiny_httpd_unix.Sem.create max_connections;
masksigpipe;
timeout;
}
in
let tcp_server_builder =
Tiny_httpd_unix.Unix_tcp_server_.to_tcp_server server
in
let module B = struct
let init_addr () = addr
let init_port () = port
let get_time_s = get_time_s
let tcp_server () = tcp_server_builder
end in
let backend = (module B : IO_BACKEND) in
Server.create_from ?buf_size ?middlewares ~backend ()

89
src/Tiny_httpd.mli
View file

@ -79,39 +79,94 @@ echo:
processing streams and parsing requests.
*)
module Buf = Tiny_httpd_buf
(** {2 Generic byte streams} *)
module Byte_stream = Tiny_httpd_stream
module Buf = Buf
(** {2 IO Abstraction} *)
module IO = Tiny_httpd_io
module IO = Tiny_httpd_core.IO
(** {2 Logging *)
module Log = Tiny_httpd_log
(** {2 Main Server Type} *)
(** @inline *)
include module type of struct
include Tiny_httpd_server
end
module Log = Tiny_httpd_core.Log
(** {2 Utils} *)
module Util = Tiny_httpd_util
module Util = Tiny_httpd_core.Util
(** {2 Resource pool} *)
module Pool = Tiny_httpd_pool
module Pool = Tiny_httpd_core.Pool
(** {2 Static directory serving} *)
module Dir = Tiny_httpd_dir
module Dir = Tiny_httpd_unix.Dir
module type VFS = Tiny_httpd_unix.Dir.VFS
(** {2 HTML combinators} *)
module Html = Tiny_httpd_html
(** Alias to {!Tiny_httpd_html}
@since 0.12 *)
(** {2 Main server types} *)
module Request = Tiny_httpd_core.Request
module Response = Tiny_httpd_core.Response
module Response_code = Tiny_httpd_core.Response_code
module Route = Tiny_httpd_core.Route
module Headers = Tiny_httpd_core.Headers
module Meth = Tiny_httpd_core.Meth
module Server = Tiny_httpd_core.Server
(** @inline *)
include module type of struct
include Server
end
val create :
?masksigpipe:bool ->
?max_connections:int ->
?timeout:float ->
?buf_size:int ->
?get_time_s:(unit -> float) ->
?new_thread:((unit -> unit) -> unit) ->
?addr:string ->
?port:int ->
?sock:Unix.file_descr ->
?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
unit ->
t
(** Create a new webserver using UNIX abstractions.
The server will not do anything until {!run} is called on it.
Before starting the server, one can use {!add_path_handler} and
{!set_top_handler} to specify how to handle incoming requests.
@param masksigpipe if true, block the signal {!Sys.sigpipe} which otherwise
tends to kill client threads when they try to write on broken sockets. Default: [true].
@param buf_size size for buffers (since 0.11)
@param new_thread a function used to spawn a new thread to handle a
new client connection. By default it is {!Thread.create} but one
could use a thread pool instead.
See for example {{: https://github.com/c-cube/tiny-httpd-moonpool-bench/blob/0dcbbffb4fe34ea4ad79d46343ad0cebb69ca69f/examples/t1.ml#L31}
this use of moonpool}.
@param middlewares see {!add_middleware} for more details.
@param max_connections maximum number of simultaneous connections.
@param timeout connection is closed if the socket does not do read or
write for the amount of second. Default: 0.0 which means no timeout.
timeout is not recommended when using proxy.
@param addr address (IPv4 or IPv6) to listen on. Default ["127.0.0.1"].
@param port to listen on. Default [8080].
@param sock an existing socket given to the server to listen on, e.g. by
systemd on Linux (or launchd on macOS). If passed in, this socket will be
used instead of the [addr] and [port]. If not passed in, those will be
used. This parameter exists since 0.10.
@param get_time_s obtain the current timestamp in seconds.
This parameter exists since 0.11.
*)

370
src/Tiny_httpd_io.ml
View file

@ -1,370 +0,0 @@
(** IO abstraction.
We abstract IO so we can support classic unix blocking IOs
with threads, and modern async IO with Eio.
{b NOTE}: experimental.
@since 0.14
*)
module Buf = Tiny_httpd_buf
(** Input channel (byte source) *)
module Input = struct
type t = {
input: bytes -> int -> int -> int;
(** Read into the slice. Returns [0] only if the
channel is closed. *)
close: unit -> unit; (** Close the input. Must be idempotent. *)
}
(** An input channel, i.e an incoming stream of bytes.
This can be a [string], an [int_channel], an [Unix.file_descr], a
decompression wrapper around another input channel, etc. *)
let of_in_channel ?(close_noerr = false) (ic : in_channel) : t =
{
input = (fun buf i len -> input ic buf i len);
close =
(fun () ->
if close_noerr then
close_in_noerr ic
else
close_in ic);
}
let of_unix_fd ?(close_noerr = false) ~closed (fd : Unix.file_descr) : t =
let eof = ref false in
{
input =
(fun buf i len ->
let n = ref 0 in
if (not !eof) && len > 0 then (
let continue = ref true in
while !continue do
(* Printf.eprintf "read %d B (from fd %d)\n%!" len (Obj.magic fd); *)
match Unix.read fd buf i len with
| n_ ->
n := n_;
continue := false
| exception
Unix.Unix_error
( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
| Unix.ECONNRESET | Unix.EPIPE ),
_,
_ ) ->
eof := true;
continue := false
| exception
Unix.Unix_error
((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
ignore (Unix.select [ fd ] [] [] 1.)
done;
(* Printf.eprintf "read returned %d B\n%!" !n; *)
if !n = 0 then eof := true
);
!n);
close =
(fun () ->
if not !closed then (
closed := true;
eof := true;
if close_noerr then (
try Unix.close fd with _ -> ()
) else
Unix.close fd
));
}
let of_slice (i_bs : bytes) (i_off : int) (i_len : int) : t =
let i_off = ref i_off in
let i_len = ref i_len in
{
input =
(fun buf i len ->
let n = min len !i_len in
Bytes.blit i_bs !i_off buf i n;
i_off := !i_off + n;
i_len := !i_len - n;
n);
close = ignore;
}
(** Read into the given slice.
@return the number of bytes read, [0] means end of input. *)
let[@inline] input (self : t) buf i len = self.input buf i len
(** Read exactly [len] bytes.
@raise End_of_file if the input did not contain enough data. *)
let really_input (self : t) buf i len : unit =
let i = ref i in
let len = ref len in
while !len > 0 do
let n = input self buf !i !len in
if n = 0 then raise End_of_file;
i := !i + n;
len := !len - n
done
(** Close the channel. *)
let[@inline] close self : unit = self.close ()
let append (i1 : t) (i2 : t) : t =
let use_i1 = ref true in
let rec input buf i len : int =
if !use_i1 then (
let n = i1.input buf i len in
if n = 0 then (
use_i1 := false;
input buf i len
) else
n
) else
i2.input buf i len
in
{
input;
close =
(fun () ->
close i1;
close i2);
}
end
(** Output channel (byte sink) *)
module Output = struct
type t = {
output_char: char -> unit; (** Output a single char *)
output: bytes -> int -> int -> unit; (** Output slice *)
flush: unit -> unit; (** Flush underlying buffer *)
close: unit -> unit; (** Close the output. Must be idempotent. *)
}
(** An output channel, ie. a place into which we can write bytes.
This can be a [Buffer.t], an [out_channel], a [Unix.file_descr], etc. *)
let of_unix_fd ?(close_noerr = false) ~closed ~(buf : Buf.t)
(fd : Unix.file_descr) : t =
Buf.clear buf;
let buf = Buf.bytes_slice buf in
let off = ref 0 in
let flush () =
if !off > 0 then (
let i = ref 0 in
while !i < !off do
(* Printf.eprintf "write %d bytes\n%!" (!off - !i); *)
match Unix.write fd buf !i (!off - !i) with
| 0 -> failwith "write failed"
| n -> i := !i + n
| exception
Unix.Unix_error
( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
| Unix.ECONNRESET | Unix.EPIPE ),
_,
_ ) ->
failwith "write failed"
| exception
Unix.Unix_error
((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
ignore (Unix.select [] [ fd ] [] 1.)
done;
off := 0
)
in
let[@inline] flush_if_full_ () = if !off = Bytes.length buf then flush () in
let output_char c =
flush_if_full_ ();
Bytes.set buf !off c;
incr off;
flush_if_full_ ()
in
let output bs i len =
(* Printf.eprintf "output %d bytes (buffered)\n%!" len; *)
let i = ref i in
let len = ref len in
while !len > 0 do
flush_if_full_ ();
let n = min !len (Bytes.length buf - !off) in
Bytes.blit bs !i buf !off n;
i := !i + n;
len := !len - n;
off := !off + n
done;
flush_if_full_ ()
in
let close () =
if not !closed then (
closed := true;
flush ();
if close_noerr then (
try Unix.close fd with _ -> ()
) else
Unix.close fd
)
in
{ output; output_char; flush; close }
(** [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 =
{
output_char = (fun c -> output_char oc c);
output = (fun buf i len -> output oc buf i len);
flush = (fun () -> flush oc);
close =
(fun () ->
if close_noerr then
close_out_noerr oc
else
close_out oc);
}
(** [of_buffer buf] is an output channel that writes directly into [buf].
[flush] and [close] have no effect. *)
let of_buffer (buf : Buffer.t) : t =
{
output_char = Buffer.add_char buf;
output = Buffer.add_subbytes buf;
flush = ignore;
close = ignore;
}
(** Output the buffer slice into this channel *)
let[@inline] output_char (self : t) c : unit = self.output_char c
(** Output the buffer slice into this channel *)
let[@inline] output (self : t) buf i len : unit = self.output buf i len
let[@inline] output_string (self : t) (str : string) : unit =
self.output (Bytes.unsafe_of_string str) 0 (String.length str)
(** Close the channel. *)
let[@inline] close self : unit = self.close ()
(** Flush (ie. force write) any buffered bytes. *)
let[@inline] flush self : unit = self.flush ()
let output_buf (self : t) (buf : Buf.t) : unit =
let b = Buf.bytes_slice buf in
output self b 0 (Buf.size buf)
(** [chunk_encoding oc] makes a new channel that outputs its content into [oc]
in chunk encoding form.
@param close_rec if true, closing the result will also close [oc]
@param buf a buffer used to accumulate data into chunks.
Chunks are emitted when [buf]'s size gets over a certain threshold,
or when [flush] is called.
*)
let chunk_encoding ?(buf = Buf.create ()) ~close_rec (self : t) : t =
(* write content of [buf] as a chunk if it's big enough.
If [force=true] then write content of [buf] if it's simply non empty. *)
let write_buf ~force () =
let n = Buf.size buf in
if (force && n > 0) || n >= 4_096 then (
output_string self (Printf.sprintf "%x\r\n" n);
self.output (Buf.bytes_slice buf) 0 n;
output_string self "\r\n";
Buf.clear buf
)
in
let flush () =
write_buf ~force:true ();
self.flush ()
in
let close () =
write_buf ~force:true ();
(* write an empty chunk to close the stream *)
output_string self "0\r\n";
(* write another crlf after the stream (see #56) *)
output_string self "\r\n";
self.flush ();
if close_rec then self.close ()
in
let output b i n =
Buf.add_bytes buf b i n;
write_buf ~force:false ()
in
let output_char c =
Buf.add_char buf c;
write_buf ~force:false ()
in
{ output_char; flush; close; output }
end
(** A writer abstraction. *)
module Writer = struct
type t = { write: Output.t -> unit } [@@unboxed]
(** Writer.
A writer is a push-based stream of bytes.
Give it an output channel and it will write the bytes in it.
This is useful for responses: an http endpoint can return a writer
as its response's body; the writer is given access to the connection
to the client and can write into it as if it were a regular
[out_channel], including controlling calls to [flush].
Tiny_httpd will convert these writes into valid HTTP chunks.
@since 0.14
*)
let[@inline] make ~write () : t = { write }
(** Write into the channel. *)
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 = Output.output_string oc str in
{ write }
end
(** A TCP server abstraction. *)
module TCP_server = struct
type conn_handler = {
handle: client_addr:Unix.sockaddr -> Input.t -> Output.t -> unit;
(** Handle client connection *)
}
type t = {
endpoint: unit -> string * int;
(** Endpoint we listen on. This can only be called from within [serve]. *)
active_connections: unit -> int;
(** Number of connections currently active *)
running: unit -> bool; (** Is the server currently running? *)
stop: unit -> unit;
(** Ask the server to stop. This might not take effect immediately,
and is idempotent. After this [server.running()] must return [false]. *)
}
(** A running TCP server.
This contains some functions that provide information about the running
server, including whether it's active (as opposed to stopped), a function
to stop it, and statistics about the number of connections. *)
type builder = {
serve: after_init:(t -> unit) -> handle:conn_handler -> unit -> unit;
(** Blocking call to listen for incoming connections and handle them.
Uses the connection handler [handle] to handle individual client
connections in individual threads/fibers/tasks.
@param after_init is called once with the server after the server
has started. *)
}
(** A TCP server builder implementation.
Calling [builder.serve ~after_init ~handle ()] starts a new TCP server on
an unspecified endpoint
(most likely coming from the function returning this builder)
and returns the running server. *)
end

1338
src/Tiny_httpd_server.ml
View file

File diff suppressed because it is too large Load diff

719
src/Tiny_httpd_server.mli
View file

@ -1,719 +0,0 @@
(** HTTP server.
This module implements a very simple, basic HTTP/1.1 server using blocking
IOs and threads.
It is possible to use a thread pool, see {!create}'s argument [new_thread].
@since 0.13
*)
type buf = Tiny_httpd_buf.t
type byte_stream = Tiny_httpd_stream.t
(** {2 HTTP Methods} *)
module Meth : sig
type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
(** A HTTP method.
For now we only handle a subset of these.
See https://tools.ietf.org/html/rfc7231#section-4 *)
val pp : Format.formatter -> t -> unit
val to_string : t -> string
end
(** {2 Headers}
Headers are metadata associated with a request or response. *)
module Headers : sig
type t = (string * string) list
(** The header files of a request or response.
Neither the key nor the value can contain ['\r'] or ['\n'].
See https://tools.ietf.org/html/rfc7230#section-3.2 *)
val empty : t
(** Empty list of headers.
@since 0.5 *)
val get : ?f:(string -> string) -> string -> t -> string option
(** [get k headers] looks for the header field with key [k].
@param f if provided, will transform the value before it is returned. *)
val set : string -> string -> t -> t
(** [set k v headers] sets the key [k] to value [v].
It erases any previous entry for [k] *)
val remove : string -> t -> t
(** Remove the key from the headers, if present. *)
val contains : string -> t -> bool
(** Is there a header with the given key? *)
val pp : Format.formatter -> t -> unit
(** Pretty print the headers. *)
end
(** {2 Requests}
Requests are sent by a client, e.g. a web browser or cURL.
From the point of view of the server, they're inputs. *)
module Request : sig
type 'body t = private {
meth: Meth.t; (** HTTP method for this request. *)
host: string;
(** Host header, mandatory. It can also be found in {!headers}. *)
client_addr: Unix.sockaddr; (** Client address. Available since 0.14. *)
headers: Headers.t; (** List of headers. *)
http_version: int * int;
(** HTTP version. This should be either [1, 0] or [1, 1]. *)
path: string; (** Full path of the requested URL. *)
path_components: string list;
(** Components of the path of the requested URL. *)
query: (string * string) list; (** Query part of the requested URL. *)
body: 'body; (** Body of the request. *)
start_time: float;
(** Obtained via [get_time_s] in {!create}
@since 0.11 *)
}
(** A request with method, path, host, headers, and a body, sent by a client.
The body is polymorphic because the request goes through
several transformations. First it has no body, as only the request
and headers are read; then it has a stream body; then the body might be
entirely read as a string via {!read_body_full}.
@since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"]
@since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"].
@since 0.11 the type is a private alias
@since 0.11 the field [start_time] was added
*)
val pp : Format.formatter -> string t -> unit
(** Pretty print the request and its body. The exact format of this printing
is not specified. *)
val pp_ : Format.formatter -> _ t -> unit
(** Pretty print the request without its body. The exact format of this printing
is not specified. *)
val headers : _ t -> Headers.t
(** List of headers of the request, including ["Host"]. *)
val get_header : ?f:(string -> string) -> _ t -> string -> string option
(** [get_header req h] looks up header [h] in [req]. It returns [None] if the
header is not present. This is case insensitive and should be used
rather than looking up [h] verbatim in [headers]. *)
val get_header_int : _ t -> string -> int option
(** Same as {!get_header} but also performs a string to integer conversion. *)
val set_header : string -> string -> 'a t -> 'a t
(** [set_header k v req] sets [k: v] in the request [req]'s headers. *)
val remove_header : string -> 'a t -> 'a t
(** Remove one instance of this header.
@since NEXT_RELEASE *)
val update_headers : (Headers.t -> Headers.t) -> 'a t -> 'a t
(** Modify headers using the given function.
@since 0.11 *)
val set_body : 'a -> _ t -> 'a t
(** [set_body b req] returns a new query whose body is [b].
@since 0.11 *)
val host : _ t -> string
(** Host field of the request. It also appears in the headers. *)
val client_addr : _ t -> Unix.sockaddr
(** Client address of the request.
@since 0.16 *)
val meth : _ t -> Meth.t
(** Method for the request. *)
val path : _ t -> string
(** Request path. *)
val query : _ t -> (string * string) list
(** Decode the query part of the {!path} field.
@since 0.4 *)
val body : 'b t -> 'b
(** Request body, possibly empty. *)
val start_time : _ t -> float
(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the request
@since 0.11 *)
val limit_body_size : max_size:int -> byte_stream t -> byte_stream t
(** Limit the body size to [max_size] bytes, or return
a [413] error.
@since 0.3
*)
val read_body_full :
?buf:Tiny_httpd_buf.t -> ?buf_size:int -> byte_stream t -> string t
(** Read the whole body into a string. Potentially blocking.
@param buf_size initial size of underlying buffer (since 0.11)
@param buf the initial buffer (since 0.14)
*)
(**/**)
(* for testing purpose, do not use. There is no guarantee of stability. *)
module Internal_ : sig
val parse_req_start :
?buf:buf ->
client_addr:Unix.sockaddr ->
get_time_s:(unit -> float) ->
byte_stream ->
unit t option
val parse_body : ?buf:buf -> unit t -> byte_stream -> byte_stream t
end
(**/**)
end
(** {2 Response Codes} *)
module Response_code : sig
type t = int
(** A standard HTTP code.
https://tools.ietf.org/html/rfc7231#section-6 *)
val ok : t
(** The code [200] *)
val not_found : t
(** The code [404] *)
val descr : t -> string
(** A description of some of the error codes.
NOTE: this is not complete (yet). *)
val is_success : t -> bool
(** [is_success code] is true iff [code] is in the [2xx] or [3xx] range.
@since NEXT_RELEASE *)
end
(** {2 Responses}
Responses are what a http server, such as {!Tiny_httpd}, send back to
the client to answer a {!Request.t}*)
module Response : sig
type body =
[ `String of string
| `Stream of byte_stream
| `Writer of Tiny_httpd_io.Writer.t
| `Void ]
(** Body of a response, either as a simple string,
or a stream of bytes, or nothing (for server-sent events notably).
- [`String str] replies with a body set to this string, and a known content-length.
- [`Stream str] replies with a body made from this string, using chunked encoding.
- [`Void] replies with no body.
- [`Writer w] replies with a body created by the writer [w], using
a chunked encoding.
It is available since 0.14.
*)
type t = private {
code: Response_code.t; (** HTTP response code. See {!Response_code}. *)
headers: Headers.t;
(** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *)
body: body; (** Body of the response. Can be empty. *)
}
(** A response to send back to a client. *)
val set_body : body -> t -> t
(** Set the body of the response.
@since 0.11 *)
val set_header : string -> string -> t -> t
(** Set a header.
@since 0.11 *)
val update_headers : (Headers.t -> Headers.t) -> t -> t
(** Modify headers.
@since 0.11 *)
val remove_header : string -> t -> t
(** Remove one instance of this header.
@since NEXT_RELEASE *)
val set_headers : Headers.t -> t -> t
(** Set all headers.
@since 0.11 *)
val set_code : Response_code.t -> t -> t
(** Set the response code.
@since 0.11 *)
val make_raw : ?headers:Headers.t -> code:Response_code.t -> string -> t
(** Make a response from its raw components, with a string body.
Use [""] to not send a body at all. *)
val make_raw_stream :
?headers:Headers.t -> code:Response_code.t -> byte_stream -> t
(** Same as {!make_raw} but with a stream body. The body will be sent with
the chunked transfer-encoding. *)
val make_void : ?headers:Headers.t -> code:int -> unit -> t
(** Return a response without a body at all.
@since 0.13 *)
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.
- [make (Error (code,msg))] replies with the given error code
and message as body.
*)
val make_string :
?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 ->
?code:int ->
(byte_stream, Response_code.t * string) result ->
t
(** Same as {!make} but with a stream body. *)
val fail :
?headers:Headers.t -> code:int -> ('a, unit, string, t) format4 -> 'a
(** Make the current request fail with the given code and message.
Example: [fail ~code:404 "oh noes, %s not found" "waldo"].
*)
val fail_raise : code:int -> ('a, unit, string, 'b) format4 -> 'a
(** Similar to {!fail} but raises an exception that exits the current handler.
This should not be used outside of a (path) handler.
Example: [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
*)
val pp : Format.formatter -> t -> unit
(** Pretty print the response. The exact format is not specified. *)
end
(** {2 Routing}
Basic type-safe routing of handlers based on URL paths. This is optional,
it is possible to only define the root handler with something like
{{: https://github.com/anuragsoni/routes/} Routes}.
@since 0.6 *)
module Route : sig
type ('a, 'b) comp
(** An atomic component of a path *)
type ('a, 'b) t
(** A route, composed of path components *)
val int : (int -> 'a, 'a) comp
(** Matches an integer. *)
val string : (string -> 'a, 'a) comp
(** Matches a string not containing ['/'] and binds it as is. *)
val string_urlencoded : (string -> 'a, 'a) comp
(** Matches a URL-encoded string, and decodes it. *)
val exact : string -> ('a, 'a) comp
(** [exact "s"] matches ["s"] and nothing else. *)
val return : ('a, 'a) t
(** Matches the empty path. *)
val rest_of_path : (string -> 'a, 'a) t
(** Matches a string, even containing ['/']. This will match
the entirety of the remaining route.
@since 0.7 *)
val rest_of_path_urlencoded : (string -> 'a, 'a) t
(** Matches a string, even containing ['/'], an URL-decode it.
This will match the entirety of the remaining route.
@since 0.7 *)
val ( @/ ) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t
(** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"],
and [route] matches ["bar/…"]. *)
val exact_path : string -> ('a, 'b) t -> ('a, 'b) t
(** [exact_path "foo/bar/..." r] is equivalent to
[exact "foo" @/ exact "bar" @/ ... @/ r]
@since 0.11 **)
val pp : Format.formatter -> _ t -> unit
(** Print the route.
@since 0.7 *)
val to_string : _ t -> string
(** Print the route.
@since 0.7 *)
end
(** {2 Middlewares}
A middleware can be inserted in a handler to modify or observe
its behavior.
@since 0.11
*)
module Middleware : sig
type handler = byte_stream Request.t -> resp:(Response.t -> unit) -> unit
(** Handlers are functions returning a response to a request.
The response can be delayed, hence the use of a continuation
as the [resp] parameter. *)
type t = handler -> handler
(** A middleware is a handler transformation.
It takes the existing handler [h],
and returns a new one which, given a query, modify it or log it
before passing it to [h], or fail. It can also log or modify or drop
the response. *)
val nil : t
(** Trivial middleware that does nothing. *)
end
(** {2 Main Server type} *)
type t
(** A HTTP server. See {!create} for more details. *)
val create :
?masksigpipe:bool ->
?max_connections:int ->
?timeout:float ->
?buf_size:int ->
?get_time_s:(unit -> float) ->
?new_thread:((unit -> unit) -> unit) ->
?addr:string ->
?port:int ->
?sock:Unix.file_descr ->
?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
unit ->
t
(** Create a new webserver using UNIX abstractions.
The server will not do anything until {!run} is called on it.
Before starting the server, one can use {!add_path_handler} and
{!set_top_handler} to specify how to handle incoming requests.
@param masksigpipe if true, block the signal {!Sys.sigpipe} which otherwise
tends to kill client threads when they try to write on broken sockets. Default: [true].
@param buf_size size for buffers (since 0.11)
@param new_thread a function used to spawn a new thread to handle a
new client connection. By default it is {!Thread.create} but one
could use a thread pool instead.
See for example {{: https://github.com/c-cube/tiny-httpd-moonpool-bench/blob/0dcbbffb4fe34ea4ad79d46343ad0cebb69ca69f/examples/t1.ml#L31}
this use of moonpool}.
@param middlewares see {!add_middleware} for more details.
@param max_connections maximum number of simultaneous connections.
@param timeout connection is closed if the socket does not do read or
write for the amount of second. Default: 0.0 which means no timeout.
timeout is not recommended when using proxy.
@param addr address (IPv4 or IPv6) to listen on. Default ["127.0.0.1"].
@param port to listen on. Default [8080].
@param sock an existing socket given to the server to listen on, e.g. by
systemd on Linux (or launchd on macOS). If passed in, this socket will be
used instead of the [addr] and [port]. If not passed in, those will be
used. This parameter exists since 0.10.
@param get_time_s obtain the current timestamp in seconds.
This parameter exists since 0.11.
*)
(** A backend that provides IO operations, network operations, etc.
This is used to decouple tiny_httpd from the scheduler/IO library used to
actually open a TCP server and talk to clients. The classic way is
based on {!Unix} and blocking IOs, but it's also possible to
use an OCaml 5 library using effects and non blocking IOs. *)
module type IO_BACKEND = sig
val init_addr : unit -> string
(** Initial TCP address *)
val init_port : unit -> int
(** Initial port *)
val get_time_s : unit -> float
(** Obtain the current timestamp in seconds. *)
val tcp_server : unit -> Tiny_httpd_io.TCP_server.builder
(** TCP server builder, to create servers that can listen
on a port and handle clients. *)
end
val create_from :
?buf_size:int ->
?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
backend:(module IO_BACKEND) ->
unit ->
t
(** Create a new webserver using provided backend.
The server will not do anything until {!run} is called on it.
Before starting the server, one can use {!add_path_handler} and
{!set_top_handler} to specify how to handle incoming requests.
@param buf_size size for buffers (since 0.11)
@param middlewares see {!add_middleware} for more details.
@since 0.14
*)
val addr : t -> string
(** Address on which the server listens. *)
val is_ipv6 : t -> bool
(** [is_ipv6 server] returns [true] iff the address of the server is an IPv6 address.
@since 0.3 *)
val port : t -> int
(** Port on which the server listens. Note that this might be different than
the port initially given if the port was [0] (meaning that the OS picks a
port for us). *)
val active_connections : t -> int
(** Number of currently active connections. *)
val add_decode_request_cb :
t ->
(unit Request.t -> (unit Request.t * (byte_stream -> byte_stream)) option) ->
unit
[@@deprecated "use add_middleware"]
(** Add a callback for every request.
The callback can provide a stream transformer and a new request (with
modified headers, typically).
A possible use is to handle decompression by looking for a [Transfer-Encoding]
header and returning a stream transformer that decompresses on the fly.
@deprecated use {!add_middleware} instead
*)
val add_encode_response_cb :
t -> (unit Request.t -> Response.t -> Response.t option) -> unit
[@@deprecated "use add_middleware"]
(** Add a callback for every request/response pair.
Similarly to {!add_encode_response_cb} the callback can return a new
response, for example to compress it.
The callback is given the query with only its headers,
as well as the current response.
@deprecated use {!add_middleware} instead
*)
val add_middleware :
stage:[ `Encoding | `Stage of int ] -> t -> Middleware.t -> unit
(** Add a middleware to every request/response pair.
@param stage specify when middleware applies.
Encoding comes first (outermost layer), then stages in increasing order.
@raise Invalid_argument if stage is [`Stage n] where [n < 1]
@since 0.11
*)
(** {2 Request handlers} *)
val set_top_handler : t -> (byte_stream Request.t -> Response.t) -> unit
(** Setup a handler called by default.
This handler is called with any request not accepted by any handler
installed via {!add_path_handler}.
If no top handler is installed, unhandled paths will return a [404] not found
This used to take a [string Request.t] but it now takes a [byte_stream Request.t]
since 0.14 . Use {!Request.read_body_full} to read the body into
a string if needed.
*)
val add_route_handler :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
?middlewares:Middleware.t list ->
?meth:Meth.t ->
t ->
('a, string Request.t -> Response.t) Route.t ->
'a ->
unit
(** [add_route_handler server Route.(exact "path" @/ string @/ int @/ return) f]
calls [f "foo" 42 request] when a [request] with path "path/foo/42/"
is received.
Note that the handlers are called in the reverse order of their addition,
so the last registered handler can override previously registered ones.
@param meth if provided, only accept requests with the given method.
Typically one could react to [`GET] or [`PUT].
@param accept should return [Ok()] if the given request (before its body
is read) should be accepted, [Error (code,message)] if it's to be rejected (e.g. because
its content is too big, or for some permission error).
See the {!http_of_dir} program for an example of how to use [accept] to
filter uploads that are too large before the upload even starts.
The default always returns [Ok()], i.e. it accepts all requests.
@since 0.6
*)
val add_route_handler_stream :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
?middlewares:Middleware.t list ->
?meth:Meth.t ->
t ->
('a, byte_stream Request.t -> Response.t) Route.t ->
'a ->
unit
(** Similar to {!add_route_handler}, but where the body of the request
is a stream of bytes that has not been read yet.
This is useful when one wants to stream the body directly into a parser,
json decoder (such as [Jsonm]) or into a file.
@since 0.6 *)
(** {2 Server-sent events}
{b EXPERIMENTAL}: this API is not stable yet. *)
(** A server-side function to generate of Server-sent events.
See {{: https://html.spec.whatwg.org/multipage/server-sent-events.html} the w3c page}
and {{: https://jvns.ca/blog/2021/01/12/day-36--server-sent-events-are-cool--and-a-fun-bug/}
this blog post}.
@since 0.9
*)
module type SERVER_SENT_GENERATOR = sig
val set_headers : Headers.t -> unit
(** Set headers of the response.
This is not mandatory but if used at all, it must be called before
any call to {!send_event} (once events are sent the response is
already sent too). *)
val send_event :
?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
(** Send an event from the server.
If data is a multiline string, it will be sent on separate "data:" lines. *)
val close : unit -> unit
(** Close connection.
@since 0.11 *)
end
type server_sent_generator = (module SERVER_SENT_GENERATOR)
(** Server-sent event generator. This generates events that are forwarded to
the client (e.g. the browser).
@since 0.9 *)
val add_route_server_sent_handler :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
t ->
('a, string Request.t -> server_sent_generator -> unit) Route.t ->
'a ->
unit
(** Add a handler on an endpoint, that serves server-sent events.
The callback is given a generator that can be used to send events
as it pleases. The connection is always closed by the client,
and the accepted method is always [GET].
This will set the header "content-type" to "text/event-stream" automatically
and reply with a 200 immediately.
See {!server_sent_generator} for more details.
This handler stays on the original thread (it is synchronous).
@since 0.9 *)
(** {2 Upgrade handlers}
These handlers upgrade the connection to another protocol.
@since NEXT_RELEASE *)
(** Handler that upgrades to another protocol.
@since NEXT_RELEASE *)
module type UPGRADE_HANDLER = sig
type handshake_state
(** Some specific state returned after handshake *)
val name : string
(** Name in the "upgrade" header *)
val handshake : unit Request.t -> (Headers.t * handshake_state, string) result
(** Perform the handshake and upgrade the connection. The returned
code is [101] alongside these headers.
In case the handshake fails, this only returns [Error log_msg].
The connection is closed without further ado. *)
val handle_connection :
Unix.sockaddr ->
handshake_state ->
Tiny_httpd_io.Input.t ->
Tiny_httpd_io.Output.t ->
unit
(** Take control of the connection and take it from ther.e *)
end
type upgrade_handler = (module UPGRADE_HANDLER)
(** @since NEXT_RELEASE *)
val add_upgrade_handler :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
t ->
('a, upgrade_handler) Route.t ->
'a ->
unit
(** {2 Run the server} *)
val running : t -> bool
(** Is the server running?
@since 0.14 *)
val stop : t -> unit
(** Ask the server to stop. This might not have an immediate effect
as {!run} might currently be waiting on IO. *)
val run : ?after_init:(unit -> unit) -> t -> (unit, exn) result
(** Run the main loop of the server, listening on a socket
described at the server's creation time, using [new_thread] to
start a thread for each new client.
This returns [Ok ()] if the server exits gracefully, or [Error e] if
it exits with an error.
@param after_init is called after the server starts listening. since 0.13 .
*)
val run_exn : ?after_init:(unit -> unit) -> t -> unit
(** [run_exn s] is like [run s] but re-raises an exception if the server exits
with an error.
@since 0.14 *)

4
src/bin/http_of_dir.ml
View file

@ -1,6 +1,6 @@
module S = Tiny_httpd
module U = Tiny_httpd_util
module D = Tiny_httpd_dir
module U = Tiny_httpd.Util
module D = Tiny_httpd.Dir
module Pf = Printf
module Log = Tiny_httpd.Log

6
src/bin/vfs_pack.ml
View file

@ -33,12 +33,12 @@ let is_url s =
is_prefix "http://" s || is_prefix "https://" s
let emit oc (l : entry list) : unit =
fpf oc "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:%f ()\n"
fpf oc "let embedded_fs = Tiny_httpd.Dir.Embedded_fs.create ~mtime:%f ()\n"
now_;
let add_vfs ~mtime vfs_path content =
fpf oc
"let () = Tiny_httpd_dir.Embedded_fs.add_file embedded_fs \n\
"let () = Tiny_httpd.Dir.Embedded_fs.add_file embedded_fs \n\
\ ~mtime:%h ~path:%S\n\
\ %S\n"
mtime vfs_path content
@ -99,7 +99,7 @@ let emit oc (l : entry list) : unit =
in
List.iter add_entry l;
fpf oc "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs\n";
fpf oc "let vfs = Tiny_httpd.Dir.Embedded_fs.to_vfs embedded_fs\n";
()
let help =

188
src/camlzip/Tiny_httpd_camlzip.ml
View file

@ -1,175 +1,59 @@
module S = Tiny_httpd_server
module BS = Tiny_httpd_stream
module W = Tiny_httpd_io.Writer
module Out = Tiny_httpd_io.Output
module Log = Tiny_httpd.Log
module W = IO.Writer
let decode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream =
(* TODO: just use iostream-camlzip? *)
let decode_deflate_stream_ ~buf_size (ic : IO.Input.t) : IO.Input.t =
Log.debug (fun k -> k "wrap stream with deflate.decode");
let zlib_str = Zlib.inflate_init false in
let is_done = ref false in
BS.make ~bs:(Bytes.create buf_size)
~close:(fun _ ->
Zlib.inflate_end zlib_str;
BS.close is)
~consume:(fun self len ->
if len > self.len then
S.Response.fail_raise ~code:400
"inflate: error during decompression: invalid consume len %d (max %d)"
len self.len;
self.off <- self.off + len;
self.len <- self.len - len)
~fill:(fun self ->
(* refill [buf] if needed *)
if self.len = 0 && not !is_done then (
is.fill_buf ();
(try
let finished, used_in, used_out =
Zlib.inflate zlib_str self.bs 0 (Bytes.length self.bs) is.bs is.off
is.len Zlib.Z_SYNC_FLUSH
in
is.consume used_in;
self.off <- 0;
self.len <- used_out;
if finished then is_done := true;
Log.debug (fun k ->
k "decode %d bytes as %d bytes from inflate (finished: %b)"
used_in used_out finished)
with Zlib.Error (e1, e2) ->
S.Response.fail_raise ~code:400
"inflate: error during decompression:\n%s %s" e1 e2);
Log.debug (fun k ->
k "inflate: refill %d bytes into internal buf" self.len)
))
()
Iostream_camlzip.decompress_in_buf ~buf_size ic
let encode_deflate_writer_ ~buf_size (w : W.t) : W.t =
Log.debug (fun k -> k "wrap writer with deflate.encode");
let zlib_str = Zlib.deflate_init 4 false in
let o_buf = Bytes.create buf_size in
let o_off = ref 0 in
let o_len = ref 0 in
(* write output buffer to out *)
let write_out (oc : Out.t) =
if !o_len > 0 then (
Out.output oc o_buf !o_off !o_len;
o_off := 0;
o_len := 0
)
let { IO.Writer.write } = w in
let write' (oc : IO.Output.t) =
let oc' = Iostream_camlzip.compressed_out ~buf_size ~level:4 oc in
write (oc' :> IO.Output.t)
in
IO.Writer.make ~write:write' ()
let flush_zlib ~flush (oc : Out.t) =
let continue = ref true in
while !continue do
let finished, used_in, used_out =
Zlib.deflate zlib_str Bytes.empty 0 0 o_buf 0 (Bytes.length o_buf) flush
in
assert (used_in = 0);
o_len := !o_len + used_out;
if finished then continue := false;
write_out oc
done
in
(* compress and consume input buffer *)
let write_zlib ~flush (oc : Out.t) buf i len =
let i = ref i in
let len = ref len in
while !len > 0 do
let _finished, used_in, used_out =
Zlib.deflate zlib_str buf !i !len o_buf 0 (Bytes.length o_buf) flush
in
i := !i + used_in;
len := !len - used_in;
o_len := !o_len + used_out;
write_out oc
done
in
let write (oc : Out.t) : unit =
let output buf i len = write_zlib ~flush:Zlib.Z_NO_FLUSH oc buf i len in
let bchar = Bytes.create 1 in
let output_char c =
Bytes.set bchar 0 c;
output bchar 0 1
in
let flush () =
flush_zlib oc ~flush:Zlib.Z_FINISH;
assert (!o_len = 0);
oc.flush ()
in
let close () =
flush ();
Zlib.deflate_end zlib_str;
oc.close ()
in
(* new output channel that compresses on the fly *)
let oc' = { Out.flush; close; output; output_char } in
w.write oc';
oc'.close ()
in
W.make ~write ()
let split_on_char ?(f = fun x -> x) c s : string list =
let rec loop acc i =
match String.index_from s i c with
| exception Not_found ->
let acc =
if i = String.length s then
acc
else
f (String.sub s i (String.length s - i)) :: acc
in
List.rev acc
| j ->
let acc = f (String.sub s i (j - i)) :: acc in
loop acc (j + 1)
in
loop [] 0
let accept_deflate (req : _ S.Request.t) =
match S.Request.get_header req "Accept-Encoding" with
| Some s -> List.mem "deflate" @@ split_on_char ~f:String.trim ',' s
let accept_deflate (req : _ Request.t) =
match Request.get_header req "Accept-Encoding" with
| Some s ->
List.mem "deflate" @@ List.rev_map String.trim @@ String.split_on_char ',' s
| None -> false
let has_deflate s =
try Scanf.sscanf s "deflate, %s" (fun _ -> true) with _ -> false
(* decompress [req]'s body if needed *)
let decompress_req_stream_ ~buf_size (req : BS.t S.Request.t) : _ S.Request.t =
match S.Request.get_header ~f:String.trim req "Transfer-Encoding" with
let decompress_req_stream_ ~buf_size (req : IO.Input.t Request.t) : _ Request.t
=
match Request.get_header ~f:String.trim req "Transfer-Encoding" with
(* TODO
| Some "gzip" ->
let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in
Some (req', decode_gzip_stream_)
*)
| Some "deflate" ->
let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in
req
|> S.Request.remove_header "Transfer-Encoding"
|> S.Request.set_body body'
let body' = Request.body req |> decode_deflate_stream_ ~buf_size in
req |> Request.remove_header "Transfer-Encoding" |> Request.set_body body'
| Some s when has_deflate s ->
(match Scanf.sscanf s "deflate, %s" (fun s -> s) with
| tr' ->
let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in
let body' = Request.body req |> decode_deflate_stream_ ~buf_size in
req
|> S.Request.set_header "Transfer-Encoding" tr'
|> S.Request.set_body body'
|> Request.set_header "Transfer-Encoding" tr'
|> Request.set_body body'
| exception _ -> req)
| _ -> req
let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t)
(resp : S.Response.t) : S.Response.t =
let compress_resp_stream_ ~compress_above ~buf_size (req : _ Request.t)
(resp : Response.t) : Response.t =
(* headers for compressed stream *)
let update_headers h =
h
|> S.Headers.remove "Content-Length"
|> S.Headers.set "Content-Encoding" "deflate"
|> Headers.remove "Content-Length"
|> Headers.set "Content-Encoding" "deflate"
in
if accept_deflate req then (
@ -181,25 +65,25 @@ let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t)
(String.length s) compress_above);
let body = encode_deflate_writer_ ~buf_size @@ W.of_string s in
resp
|> S.Response.update_headers update_headers
|> S.Response.set_body (`Writer body)
| `Stream str ->
|> Response.update_headers update_headers
|> Response.set_body (`Writer body)
| `Stream ic ->
Log.debug (fun k -> k "encode stream response with deflate");
let w = BS.to_writer str in
let w = IO.Writer.of_input ic in
resp
|> S.Response.update_headers update_headers
|> S.Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
|> Response.update_headers update_headers
|> Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
| `Writer w ->
Log.debug (fun k -> k "encode writer response with deflate");
resp
|> S.Response.update_headers update_headers
|> S.Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
|> Response.update_headers update_headers
|> Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
| `String _ | `Void -> resp
) else
resp
let middleware ?(compress_above = 16 * 1024) ?(buf_size = 16 * 1_024) () :
S.Middleware.t =
Server.Middleware.t =
let buf_size = max buf_size 1_024 in
fun h req ~resp ->
let req = decompress_req_stream_ ~buf_size req in
@ -209,4 +93,4 @@ let middleware ?(compress_above = 16 * 1024) ?(buf_size = 16 * 1_024) () :
let setup ?compress_above ?buf_size server =
let m = middleware ?compress_above ?buf_size () in
Log.info (fun k -> k "setup gzip middleware");
S.add_middleware ~stage:`Encoding server m
Server.add_middleware ~stage:`Encoding server m

4
src/camlzip/Tiny_httpd_camlzip.mli
View file

@ -7,7 +7,7 @@
*)
val middleware :
?compress_above:int -> ?buf_size:int -> unit -> Tiny_httpd_server.Middleware.t
?compress_above:int -> ?buf_size:int -> unit -> Server.Middleware.t
(** Middleware responsible for deflate compression/decompression.
@param compress_above threshold, in bytes, above which a response body
that has a known content-length is compressed. Stream bodies
@ -15,7 +15,7 @@ val middleware :
@param buf_size size of the underlying buffer for compression/decompression
@since 0.11 *)
val setup : ?compress_above:int -> ?buf_size:int -> Tiny_httpd_server.t -> unit
val setup : ?compress_above:int -> ?buf_size:int -> Server.t -> unit
(** Install middleware for tiny_httpd to be able to encode/decode
compressed streams
@param compress_above threshold above with string responses are compressed

4
src/camlzip/dune
View file

@ -2,5 +2,5 @@
(name tiny_httpd_camlzip)
(public_name tiny_httpd_camlzip)
(synopsis "A wrapper around camlzip to bring compression to Tiny_httpd")
(flags :standard -safe-string -warn-error -a+8)
(libraries tiny_httpd camlzip))
(flags :standard -open Tiny_httpd_core -safe-string -warn-error -a+8)
(libraries tiny_httpd.core iostream-camlzip camlzip))

478
src/core/IO.ml Normal file
View file

@ -0,0 +1,478 @@
(** IO abstraction.
We abstract IO so we can support classic unix blocking IOs
with threads, and modern async IO with Eio.
{b NOTE}: experimental.
@since 0.14
*)
open Common_
module Buf = Buf
module Slice = Iostream.Slice
(** Output channel (byte sink) *)
module Output = struct
include Iostream.Out_buf
class of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
(fd : Unix.file_descr) : t =
object
inherit t_from_output ~bytes:buf.bytes ()
method private output_underlying bs i len0 =
let i = ref i in
let len = ref len0 in
while !len > 0 do
match Unix.write fd bs !i !len with
| 0 -> failwith "write failed"
| n ->
i := !i + n;
len := !len - n
| exception
Unix.Unix_error
( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
| Unix.ECONNRESET | Unix.EPIPE ),
_,
_ ) ->
failwith "write failed"
| exception
Unix.Unix_error
((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
ignore (Unix.select [] [ fd ] [] 1.)
done
method private close_underlying () =
if not !closed then (
closed := true;
if close_noerr then (
try Unix.close fd with _ -> ()
) else
Unix.close fd
)
end
let output_buf (self : t) (buf : Buf.t) : unit =
let b = Buf.bytes_slice buf in
output self b 0 (Buf.size buf)
(** [chunk_encoding oc] makes a new channel that outputs its content into [oc]
in chunk encoding form.
@param close_rec if true, closing the result will also close [oc]
@param buf a buffer used to accumulate data into chunks.
Chunks are emitted when [buf]'s size gets over a certain threshold,
or when [flush] is called.
*)
let chunk_encoding ?(buf = Buf.create ()) ~close_rec (oc : #t) : t =
(* write content of [buf] as a chunk if it's big enough.
If [force=true] then write content of [buf] if it's simply non empty. *)
let write_buf ~force () =
let n = Buf.size buf in
if (force && n > 0) || n >= 4_096 then (
output_string oc (Printf.sprintf "%x\r\n" n);
output oc (Buf.bytes_slice buf) 0 n;
output_string oc "\r\n";
Buf.clear buf
)
in
object
method flush () =
write_buf ~force:true ();
flush oc
method close () =
write_buf ~force:true ();
(* write an empty chunk to close the stream *)
output_string oc "0\r\n";
(* write another crlf after the stream (see #56) *)
output_string oc "\r\n";
flush oc;
if close_rec then close oc
method output b i n =
Buf.add_bytes buf b i n;
write_buf ~force:false ()
method output_char c =
Buf.add_char buf c;
write_buf ~force:false ()
end
end
(** Input channel (byte source) *)
module Input = struct
include Iostream.In_buf
let of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
(fd : Unix.file_descr) : t =
let eof = ref false in
object
inherit Iostream.In_buf.t_from_refill ~bytes:buf.bytes ()
method private refill (slice : Slice.t) =
if not !eof then (
slice.off <- 0;
let continue = ref true in
while !continue do
match Unix.read fd slice.bytes 0 (Bytes.length slice.bytes) with
| n ->
slice.len <- n;
continue := false
| exception
Unix.Unix_error
( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
| Unix.ECONNRESET | Unix.EPIPE ),
_,
_ ) ->
eof := true;
continue := false
| exception
Unix.Unix_error
((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
ignore (Unix.select [ fd ] [] [] 1.)
done;
(* Printf.eprintf "read returned %d B\n%!" !n; *)
if slice.len = 0 then eof := true
)
method close () =
if not !closed then (
closed := true;
eof := true;
if close_noerr then (
try Unix.close fd with _ -> ()
) else
Unix.close fd
)
end
let of_slice (slice : Slice.t) : t =
object
inherit Iostream.In_buf.t_from_refill ~bytes:slice.bytes ()
method private refill (slice : Slice.t) =
slice.off <- 0;
slice.len <- 0
method close () = ()
end
(** Read into the given slice.
@return the number of bytes read, [0] means end of input. *)
let[@inline] input (self : t) buf i len = self#input buf i len
(** Close the channel. *)
let[@inline] close self : unit = self#close ()
(** Read exactly [len] bytes.
@raise End_of_file if the input did not contain enough data. *)
let really_input (self : t) buf i len : unit =
let i = ref i in
let len = ref len in
while !len > 0 do
let n = input self buf !i !len in
if n = 0 then raise End_of_file;
i := !i + n;
len := !len - n
done
let append (i1 : #t) (i2 : #t) : t =
let use_i1 = ref true in
let rec input_rec (slice : Slice.t) =
if !use_i1 then (
slice.len <- input i1 slice.bytes 0 (Bytes.length slice.bytes);
if slice.len = 0 then (
use_i1 := false;
input_rec slice
)
) else
slice.len <- input i1 slice.bytes 0 (Bytes.length slice.bytes)
in
object
inherit Iostream.In_buf.t_from_refill ()
method private refill (slice : Slice.t) =
slice.off <- 0;
input_rec slice
method close () =
close i1;
close i2
end
let iter_slice (f : Slice.t -> unit) (self : #t) : unit =
let continue = ref true in
while !continue do
let slice = self#fill_buf () in
if slice.len = 0 then (
continue := false;
close self
) else (
f slice;
Slice.consume slice slice.len
)
done
let iter f self =
iter_slice (fun (slice : Slice.t) -> f slice.bytes slice.off slice.len) self
let to_chan oc (self : #t) =
iter_slice
(fun (slice : Slice.t) ->
Stdlib.output oc slice.bytes slice.off slice.len)
self
let to_chan' (oc : #Iostream.Out.t) (self : #t) : unit =
iter_slice
(fun (slice : Slice.t) ->
Iostream.Out.output oc slice.bytes slice.off slice.len)
self
let read_all_using ~buf (self : #t) : string =
Buf.clear buf;
let continue = ref true in
while !continue do
let slice = fill_buf self in
if slice.len = 0 then
continue := false
else (
assert (slice.len > 0);
Buf.add_bytes buf slice.bytes slice.off slice.len;
Slice.consume slice slice.len
)
done;
Buf.contents_and_clear buf
(** Read [n] bytes from the input into [bytes]. *)
let read_exactly_ ~too_short (self : #t) (bytes : bytes) (n : int) : unit =
assert (Bytes.length bytes >= n);
let offset = ref 0 in
while !offset < n do
let slice = self#fill_buf () in
let n_read = min slice.len (n - !offset) in
Bytes.blit slice.bytes slice.off bytes !offset n_read;
offset := !offset + n_read;
Slice.consume slice n_read;
if n_read = 0 then too_short ()
done
(** read a line into the buffer, after clearing it. *)
let read_line_into (self : t) ~buf : unit =
Buf.clear buf;
let continue = ref true in
while !continue do
let slice = self#fill_buf () in
if slice.len = 0 then (
continue := false;
if Buf.size buf = 0 then raise End_of_file
);
let j = ref slice.off in
while !j < slice.off + slice.len && Bytes.get slice.bytes !j <> '\n' do
incr j
done;
if !j - slice.off < slice.len then (
assert (Bytes.get slice.bytes !j = '\n');
(* line without '\n' *)
Buf.add_bytes buf slice.bytes slice.off (!j - slice.off);
(* consume line + '\n' *)
Slice.consume slice (!j - slice.off + 1);
continue := false
) else (
Buf.add_bytes buf slice.bytes slice.off slice.len;
Slice.consume slice slice.len
)
done
let read_line_using ~buf (self : #t) : string =
read_line_into self ~buf;
Buf.contents_and_clear buf
let read_line_using_opt ~buf (self : #t) : string option =
match read_line_into self ~buf with
| () -> Some (Buf.contents_and_clear buf)
| exception End_of_file -> None
(* helper for making a new input stream that either contains at most [size]
bytes, or contains exactly [size] bytes. *)
let reading_exactly_ ~skip_on_close ~close_rec ~size ~bytes (arg : t) : t =
let remaining_size = ref size in
object
inherit t_from_refill ~bytes ()
method close () =
if !remaining_size > 0 && skip_on_close then skip arg !remaining_size;
if close_rec then close arg
method private refill (slice : Slice.t) =
slice.off <- 0;
slice.len <- 0;
if !remaining_size > 0 then (
let sub = fill_buf arg in
let n =
min !remaining_size (min sub.len (Bytes.length slice.bytes))
in
Bytes.blit sub.bytes sub.off slice.bytes 0 n;
Slice.consume sub n;
remaining_size := !remaining_size - n;
slice.len <- n
)
end
(** new stream with maximum size [max_size].
@param close_rec if true, closing this will also close the input stream *)
let limit_size_to ~close_rec ~max_size ~bytes (arg : t) : t =
reading_exactly_ ~size:max_size ~skip_on_close:false ~bytes ~close_rec arg
(** New stream that consumes exactly [size] bytes from the input.
If fewer bytes are read before [close] is called, we read and discard
the remaining quota of bytes before [close] returns.
@param close_rec if true, closing this will also close the input stream *)
let reading_exactly ~close_rec ~size ~bytes (arg : t) : t =
reading_exactly_ ~size ~close_rec ~skip_on_close:true ~bytes arg
let read_chunked ~(bytes : bytes) ~fail (ic : #t) : t =
let first = ref true in
(* small buffer to read the chunk sizes *)
let line_buf = Buf.create ~size:32 () in
let read_next_chunk_len () : int =
if !first then
first := false
else (
let line = read_line_using ~buf:line_buf ic in
if String.trim line <> "" then
raise (fail "expected crlf between chunks")
);
let line = read_line_using ~buf:line_buf ic in
(* parse chunk length, ignore extensions *)
let chunk_size =
if String.trim line = "" then
0
else (
try
let off = ref 0 in
let n = Parse_.pos_hex line off in
n
with _ ->
raise (fail (spf "cannot read chunk size from line %S" line))
)
in
chunk_size
in
let eof = ref false in
let chunk_size = ref 0 in
object
inherit t_from_refill ~bytes ()
method private refill (slice : Slice.t) : unit =
if !chunk_size = 0 && not !eof then (
chunk_size := read_next_chunk_len ();
if !chunk_size = 0 then eof := true (* stream is finished *)
);
slice.off <- 0;
slice.len <- 0;
if !chunk_size > 0 then (
(* read the whole chunk, or [Bytes.length bytes] of it *)
let to_read = min !chunk_size (Bytes.length slice.bytes) in
read_exactly_
~too_short:(fun () -> raise (fail "chunk is too short"))
ic slice.bytes to_read;
slice.len <- to_read;
chunk_size := !chunk_size - to_read
)
method close () = eof := true (* do not close underlying stream *)
end
(** Output a stream using chunked encoding *)
let output_chunked' ?buf (oc : #Iostream.Out_buf.t) (self : #t) : unit =
let oc' = Output.chunk_encoding ?buf oc ~close_rec:false in
match to_chan' oc' self with
| () -> Output.close oc'
| exception e ->
let bt = Printexc.get_raw_backtrace () in
Output.close oc';
Printexc.raise_with_backtrace e bt
(** print a stream as a series of chunks *)
let output_chunked ?buf (oc : out_channel) (self : #t) : unit =
output_chunked' ?buf (Output.of_out_channel oc) self
end
(** A writer abstraction. *)
module Writer = struct
type t = { write: Output.t -> unit } [@@unboxed]
(** Writer.
A writer is a push-based stream of bytes.
Give it an output channel and it will write the bytes in it.
This is useful for responses: an http endpoint can return a writer
as its response's body; the writer is given access to the connection
to the client and can write into it as if it were a regular
[out_channel], including controlling calls to [flush].
Tiny_httpd will convert these writes into valid HTTP chunks.
@since 0.14
*)
let[@inline] make ~write () : t = { write }
(** Write into the channel. *)
let[@inline] write (oc : #Output.t) (self : t) : unit =
self.write (oc :> Output.t)
(** 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 = Iostream.Out.output_string oc str in
{ write }
let[@inline] of_input (ic : #Input.t) : t =
{ write = (fun oc -> Input.to_chan' oc ic) }
end
(** A TCP server abstraction. *)
module TCP_server = struct
type conn_handler = {
handle: client_addr:Unix.sockaddr -> Input.t -> Output.t -> unit;
(** Handle client connection *)
}
type t = {
endpoint: unit -> string * int;
(** Endpoint we listen on. This can only be called from within [serve]. *)
active_connections: unit -> int;
(** Number of connections currently active *)
running: unit -> bool; (** Is the server currently running? *)
stop: unit -> unit;
(** Ask the server to stop. This might not take effect immediately,
and is idempotent. After this [server.running()] must return [false]. *)
}
(** A running TCP server.
This contains some functions that provide information about the running
server, including whether it's active (as opposed to stopped), a function
to stop it, and statistics about the number of connections. *)
type builder = {
serve: after_init:(t -> unit) -> handle:conn_handler -> unit -> unit;
(** Blocking call to listen for incoming connections and handle them.
Uses the connection handler [handle] to handle individual client
connections in individual threads/fibers/tasks.
@param after_init is called once with the server after the server
has started. *)
}
(** A TCP server builder implementation.
Calling [builder.serve ~after_init ~handle ()] starts a new TCP server on
an unspecified endpoint
(most likely coming from the function returning this builder)
and returns the running server. *)
end

1
src/Tiny_httpd_buf.ml → src/core/buf.ml
View file

@ -4,6 +4,7 @@ let create ?(size = 4_096) () : t =
let bytes = Bytes.make size ' ' in
{ bytes; i = 0; original = bytes }
let of_bytes bytes : t = { bytes; i = 0; original = bytes }
let[@inline] size self = self.i
let[@inline] bytes_slice self = self.bytes

1
src/Tiny_httpd_buf.mli → src/core/buf.mli
View file

@ -11,6 +11,7 @@ type t
val size : t -> int
val clear : t -> unit
val create : ?size:int -> unit -> t
val of_bytes : bytes -> t
val contents : t -> string
val clear_and_zero : t -> unit

10
src/core/common_.ml Normal file
View file

@ -0,0 +1,10 @@
exception Bad_req of int * string
let spf = Printf.sprintf
let bad_reqf c fmt = Printf.ksprintf (fun s -> raise (Bad_req (c, s))) fmt
type 'a resp_result = ('a, int * string) result
let unwrap_resp_result = function
| Ok x -> x
| Error (c, s) -> raise (Bad_req (c, s))

18
src/core/dune Normal file
View file

@ -0,0 +1,18 @@
(library
(name tiny_httpd_core)
(public_name tiny_httpd.core)
(private_modules parse_ common_)
(libraries threads seq hmap iostream
(select log.ml from
(logs -> log.logs.ml)
(-> log.default.ml))))
(rule
(targets Atomic_.ml)
(deps
(:bin ./gen/mkshims.exe))
(action
(with-stdout-to
%{targets}
(run %{bin}))))

2
src/core/gen/dune Normal file
View file

@ -0,0 +1,2 @@
(executables
(names mkshims))

0
src/gen/mkshims.ml → src/core/gen/mkshims.ml
View file

70
src/core/headers.ml Normal file
View file

@ -0,0 +1,70 @@
open Common_
type t = (string * string) list
let empty = []
let contains name headers =
let name' = String.lowercase_ascii name in
List.exists (fun (n, _) -> name' = n) headers
let get_exn ?(f = fun x -> x) x h =
let x' = String.lowercase_ascii x in
List.assoc x' h |> f
let get ?(f = fun x -> x) x h =
try Some (get_exn ~f x h) with Not_found -> None
let remove x h =
let x' = String.lowercase_ascii x in
List.filter (fun (k, _) -> k <> x') h
let set x y h =
let x' = String.lowercase_ascii x in
(x', y) :: List.filter (fun (k, _) -> k <> x') h
let pp out l =
let pp_pair out (k, v) = Format.fprintf out "@[<h>%s: %s@]" k v in
Format.fprintf out "@[<v>%a@]" (Format.pp_print_list pp_pair) l
(* token = 1*tchar
tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" / "_"
/ "`" / "|" / "~" / DIGIT / ALPHA ; any VCHAR, except delimiters
Reference: https://datatracker.ietf.org/doc/html/rfc7230#section-3.2 *)
let is_tchar = function
| '0' .. '9'
| 'a' .. 'z'
| 'A' .. 'Z'
| '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' | '_' | '`'
| '|' | '~' ->
true
| _ -> false
let for_all pred s =
try
String.iter (fun c -> if not (pred c) then raise Exit) s;
true
with Exit -> false
let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
let rec loop acc =
match IO.Input.read_line_using_opt ~buf bs with
| None -> raise End_of_file
| Some "\r" -> acc
| Some line ->
Log.debug (fun k -> k "parsed header line %S" line);
let k, v =
try
let i = String.index line ':' in
let k = String.sub line 0 i in
if not (for_all is_tchar k) then
invalid_arg (Printf.sprintf "Invalid header key: %S" k);
let v =
String.sub line (i + 1) (String.length line - i - 1) |> String.trim
in
k, v
with _ -> bad_reqf 400 "invalid header line: %S" line
in
loop ((String.lowercase_ascii k, v) :: acc)
in
loop []

35
src/core/headers.mli Normal file
View file

@ -0,0 +1,35 @@
(** Headers
Headers are metadata associated with a request or response. *)
type t = (string * string) list
(** The header files of a request or response.
Neither the key nor the value can contain ['\r'] or ['\n'].
See https://tools.ietf.org/html/rfc7230#section-3.2 *)
val empty : t
(** Empty list of headers.
@since 0.5 *)
val get : ?f:(string -> string) -> string -> t -> string option
(** [get k headers] looks for the header field with key [k].
@param f if provided, will transform the value before it is returned. *)
val get_exn : ?f:(string -> string) -> string -> t -> string
(** @raise Not_found *)
val set : string -> string -> t -> t
(** [set k v headers] sets the key [k] to value [v].
It erases any previous entry for [k] *)
val remove : string -> t -> t
(** Remove the key from the headers, if present. *)
val contains : string -> t -> bool
(** Is there a header with the given key? *)
val pp : Format.formatter -> t -> unit
(** Pretty print the headers. *)
val parse_ : buf:Buf.t -> IO.Input.t -> t

0
src/Tiny_httpd_log.default.ml → src/core/log.default.ml
View file

0
src/Tiny_httpd_log.logs.ml → src/core/log.logs.ml
View file

0
src/Tiny_httpd_log.mli → src/core/log.mli
View file

22
src/core/meth.ml Normal file
View file

@ -0,0 +1,22 @@
open Common_
type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
let to_string = function
| `GET -> "GET"
| `PUT -> "PUT"
| `HEAD -> "HEAD"
| `POST -> "POST"
| `DELETE -> "DELETE"
| `OPTIONS -> "OPTIONS"
let pp out s = Format.pp_print_string out (to_string s)
let of_string = function
| "GET" -> `GET
| "PUT" -> `PUT
| "POST" -> `POST
| "HEAD" -> `HEAD
| "DELETE" -> `DELETE
| "OPTIONS" -> `OPTIONS
| s -> bad_reqf 400 "unknown method %S" s

11
src/core/meth.mli Normal file
View file

@ -0,0 +1,11 @@
(** HTTP Methods *)
type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
(** A HTTP method.
For now we only handle a subset of these.
See https://tools.ietf.org/html/rfc7231#section-4 *)
val pp : Format.formatter -> t -> unit
val to_string : t -> string
val of_string : string -> t

0
src/Tiny_httpd_parse_.ml → src/core/parse_.ml
View file

2
src/Tiny_httpd_pool.ml → src/core/pool.ml
View file

@ -1,4 +1,4 @@
module A = Tiny_httpd_atomic_
module A = Atomic_
type 'a list_ = Nil | Cons of int * 'a * 'a list_

0
src/Tiny_httpd_pool.mli → src/core/pool.mli
View file

231
src/core/request.ml Normal file
View file

@ -0,0 +1,231 @@
open Common_
type 'body t = {
meth: Meth.t;
host: string;
client_addr: Unix.sockaddr;
headers: Headers.t;
mutable meta: Hmap.t;
http_version: int * int;
path: string;
path_components: string list;
query: (string * string) list;
body: 'body;
start_time: float;
}
let headers self = self.headers
let host self = self.host
let client_addr self = self.client_addr
let meth self = self.meth
let path self = self.path
let body self = self.body
let start_time self = self.start_time
let query self = self.query
let get_header ?f self h = Headers.get ?f h self.headers
let remove_header k self = { self with headers = Headers.remove k self.headers }
let add_meta self k v = self.meta <- Hmap.add k v self.meta
let get_meta self k = Hmap.find k self.meta
let get_meta_exn self k = Hmap.get k self.meta
let get_header_int self h =
match get_header self h with
| Some x -> (try Some (int_of_string x) with _ -> None)
| None -> None
let set_header k v self = { self with headers = Headers.set k v self.headers }
let update_headers f self = { self with headers = f self.headers }
let set_body b self = { self with body = b }
(** Should we close the connection after this request? *)
let close_after_req (self : _ t) : bool =
match self.http_version with
| 1, 1 -> get_header self "connection" = Some "close"
| 1, 0 -> not (get_header self "connection" = Some "keep-alive")
| _ -> false
let pp_comp_ out comp =
Format.fprintf out "[%s]"
(String.concat ";" @@ List.map (Printf.sprintf "%S") comp)
let pp_query out q =
Format.fprintf out "[%s]"
(String.concat ";" @@ List.map (fun (a, b) -> Printf.sprintf "%S,%S" a b) q)
let pp_with ?(mask_header = fun _ -> false)
?(headers_to_mask = [ "authorization"; "cookie" ]) ?(show_query = true)
?(pp_body = fun out _ -> Format.pp_print_string out "?") () out self : unit
=
let pp_query out q =
if show_query then
pp_query out q
else
Format.fprintf out "<hidden>"
in
let headers_to_mask = List.rev_map String.lowercase_ascii headers_to_mask in
(* hide some headers *)
let headers =
List.map
(fun (k, v) ->
let hidden = List.mem k headers_to_mask || mask_header k in
if hidden then
k, "<hidden>"
else
k, v)
self.headers
in
Format.fprintf out
"{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ body=%a;@ \
path_components=%a;@ query=%a@]}"
(Meth.to_string self.meth) self.host Headers.pp headers self.path pp_body
self.body pp_comp_ self.path_components pp_query self.query
let pp_ out self : unit = pp_with () out self
let pp out self : unit =
let pp_body out b = Format.fprintf out "%S" b in
pp_with ~pp_body () out self
(* decode a "chunked" stream into a normal stream *)
let read_stream_chunked_ ~bytes (bs : #IO.Input.t) : IO.Input.t =
Log.debug (fun k -> k "body: start reading chunked stream...");
IO.Input.read_chunked ~bytes ~fail:(fun s -> Bad_req (400, s)) bs
let limit_body_size_ ~max_size ~bytes (bs : #IO.Input.t) : IO.Input.t =
Log.debug (fun k -> k "limit size of body to max-size=%d" max_size);
IO.Input.limit_size_to ~max_size ~close_rec:false ~bytes bs
let limit_body_size ~max_size ~bytes (req : IO.Input.t t) : IO.Input.t t =
{ req with body = limit_body_size_ ~max_size ~bytes req.body }
(** read exactly [size] bytes from the stream *)
let read_exactly ~size ~bytes (bs : #IO.Input.t) : IO.Input.t =
Log.debug (fun k -> k "body: must read exactly %d bytes" size);
IO.Input.reading_exactly bs ~close_rec:false ~bytes ~size
(* parse request, but not body (yet) *)
let parse_req_start ~client_addr ~get_time_s ~buf (bs : IO.Input.t) :
unit t option resp_result =
try
let line = IO.Input.read_line_using ~buf bs in
Log.debug (fun k -> k "parse request line: %s" line);
let start_time = get_time_s () in
let meth, path, version =
try
let off = ref 0 in
let meth = Parse_.word line off in
let path = Parse_.word line off in
let http_version = Parse_.word line off in
let version =
match http_version with
| "HTTP/1.1" -> 1
| "HTTP/1.0" -> 0
| v -> invalid_arg (spf "unsupported HTTP version: %s" v)
in
meth, path, version
with
| Invalid_argument msg ->
Log.error (fun k -> k "invalid request line: `%s`: %s" line msg);
raise (Bad_req (400, "Invalid request line"))
| _ ->
Log.error (fun k -> k "invalid request line: `%s`" line);
raise (Bad_req (400, "Invalid request line"))
in
let meth = Meth.of_string meth in
Log.debug (fun k -> k "got meth: %s, path %S" (Meth.to_string meth) path);
let headers = Headers.parse_ ~buf bs in
let host =
match Headers.get "Host" headers with
| None -> bad_reqf 400 "No 'Host' header in request"
| Some h -> h
in
let path_components, query = Util.split_query path in
let path_components = Util.split_on_slash path_components in
let query =
match Util.parse_query query with
| Ok l -> l
| Error e -> bad_reqf 400 "invalid query: %s" e
in
let req =
{
meth;
query;
host;
meta = Hmap.empty;
client_addr;
path;
path_components;
headers;
http_version = 1, version;
body = ();
start_time;
}
in
Ok (Some req)
with
| End_of_file | Sys_error _ | Unix.Unix_error _ -> Ok None
| Bad_req (c, s) -> Error (c, s)
| e -> Error (400, Printexc.to_string e)
(* parse body, given the headers.
@param tr_stream a transformation of the input stream. *)
let parse_body_ ~tr_stream ~bytes (req : IO.Input.t t) :
IO.Input.t t resp_result =
try
let size, has_size =
match Headers.get_exn "Content-Length" req.headers |> int_of_string with
| n -> n, true (* body of fixed size *)
| exception Not_found -> 0, false
| exception _ -> bad_reqf 400 "invalid content-length"
in
let body =
match get_header ~f:String.trim req "Transfer-Encoding" with
| None -> read_exactly ~size ~bytes @@ tr_stream req.body
| Some "chunked" when has_size ->
bad_reqf 400 "specifying both transfer-encoding and content-length"
| Some "chunked" ->
(* body sent by chunks *)
let bs : IO.Input.t =
read_stream_chunked_ ~bytes @@ tr_stream req.body
in
if size > 0 then (
(* TODO: ensure we recycle [bytes] when the new input is closed *)
let bytes = Bytes.create 4096 in
limit_body_size_ ~max_size:size ~bytes bs
) else
bs
| Some s -> bad_reqf 500 "cannot handle transfer encoding: %s" s
in
Ok { req with body }
with
| End_of_file -> Error (400, "unexpected end of file")
| Bad_req (c, s) -> Error (c, s)
| e -> Error (400, Printexc.to_string e)
let read_body_full ?bytes ?buf_size (self : IO.Input.t t) : string t =
try
let buf =
match bytes with
| Some b -> Buf.of_bytes b
| None -> Buf.create ?size:buf_size ()
in
let body = IO.Input.read_all_using ~buf self.body in
{ self with body }
with
| Bad_req _ as e -> raise e
| e -> bad_reqf 500 "failed to read body: %s" (Printexc.to_string e)
module Private_ = struct
let close_after_req = close_after_req
let parse_req_start = parse_req_start
let parse_req_start_exn ?(buf = Buf.create ()) ~client_addr ~get_time_s bs =
parse_req_start ~client_addr ~get_time_s ~buf bs |> unwrap_resp_result
let parse_body ?(bytes = Bytes.create 4096) req bs : _ t =
parse_body_ ~tr_stream:(fun s -> s) ~bytes { req with body = bs }
|> unwrap_resp_result
let[@inline] set_body body self = { self with body }
end

168
src/core/request.mli Normal file
View file

@ -0,0 +1,168 @@
(** Requests
Requests are sent by a client, e.g. a web browser or cURL.
From the point of view of the server, they're inputs. *)
open Common_
type 'body t = private {
meth: Meth.t; (** HTTP method for this request. *)
host: string;
(** Host header, mandatory. It can also be found in {!headers}. *)
client_addr: Unix.sockaddr; (** Client address. Available since 0.14. *)
headers: Headers.t; (** List of headers. *)
mutable meta: Hmap.t; (** Metadata. @since NEXT_RELEASE *)
http_version: int * int;
(** HTTP version. This should be either [1, 0] or [1, 1]. *)
path: string; (** Full path of the requested URL. *)
path_components: string list;
(** Components of the path of the requested URL. *)
query: (string * string) list; (** Query part of the requested URL. *)
body: 'body; (** Body of the request. *)
start_time: float;
(** Obtained via [get_time_s] in {!create}
@since 0.11 *)
}
(** A request with method, path, host, headers, and a body, sent by a client.
The body is polymorphic because the request goes through
several transformations. First it has no body, as only the request
and headers are read; then it has a stream body; then the body might be
entirely read as a string via {!read_body_full}.
@since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"]
@since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"].
@since 0.11 the type is a private alias
@since 0.11 the field [start_time] was added
*)
val add_meta : _ t -> 'a Hmap.key -> 'a -> unit
(** Add metadata
@since NEXT_RELEASE *)
val get_meta : _ t -> 'a Hmap.key -> 'a option
(** Get metadata
@since NEXT_RELEASE *)
val get_meta_exn : _ t -> 'a Hmap.key -> 'a
(** Like {!get_meta} but can fail
@raise Invalid_argument if not present
@since NEXT_RELEASE *)
val pp_with :
?mask_header:(string -> bool) ->
?headers_to_mask:string list ->
?show_query:bool ->
?pp_body:(Format.formatter -> 'body -> unit) ->
unit ->
Format.formatter ->
'body t ->
unit
(** Pretty print the request. The exact format of this printing
is not specified.
@param mask_header function which is given each header name. If it
returns [true], the header's value is masked. The presence of
the header is still printed. Default [fun _ -> false].
@param headers_to_mask a list of headers masked by default.
Default is ["authorization"; "cookie"].
@show_query if [true] (default [true]), the query part of the
request is shown.
@param pp_body body printer (default prints "?" instead of the body,
which works even for stream bodies) *)
val pp : Format.formatter -> string t -> unit
(** Pretty print the request and its body. The exact format of this printing
is not specified. *)
val pp_ : Format.formatter -> _ t -> unit
(** Pretty print the request without its body. The exact format of this printing
is not specified. *)
val headers : _ t -> Headers.t
(** List of headers of the request, including ["Host"]. *)
val get_header : ?f:(string -> string) -> _ t -> string -> string option
(** [get_header req h] looks up header [h] in [req]. It returns [None] if the
header is not present. This is case insensitive and should be used
rather than looking up [h] verbatim in [headers]. *)
val get_header_int : _ t -> string -> int option
(** Same as {!get_header} but also performs a string to integer conversion. *)
val set_header : string -> string -> 'a t -> 'a t
(** [set_header k v req] sets [k: v] in the request [req]'s headers. *)
val remove_header : string -> 'a t -> 'a t
(** Remove one instance of this header.
@since NEXT_RELEASE *)
val update_headers : (Headers.t -> Headers.t) -> 'a t -> 'a t
(** Modify headers using the given function.
@since 0.11 *)
val set_body : 'a -> _ t -> 'a t
(** [set_body b req] returns a new query whose body is [b].
@since 0.11 *)
val host : _ t -> string
(** Host field of the request. It also appears in the headers. *)
val client_addr : _ t -> Unix.sockaddr
(** Client address of the request.
@since 0.16 *)
val meth : _ t -> Meth.t
(** Method for the request. *)
val path : _ t -> string
(** Request path. *)
val query : _ t -> (string * string) list
(** Decode the query part of the {!path} field.
@since 0.4 *)
val body : 'b t -> 'b
(** Request body, possibly empty. *)
val start_time : _ t -> float
(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the request
@since 0.11 *)
val limit_body_size :
max_size:int -> bytes:bytes -> IO.Input.t t -> IO.Input.t t
(** Limit the body size to [max_size] bytes, or return
a [413] error.
@since 0.3
*)
val read_body_full : ?bytes:bytes -> ?buf_size:int -> IO.Input.t t -> string t
(** Read the whole body into a string. Potentially blocking.
@param buf_size initial size of underlying buffer (since 0.11)
@param bytes the initial buffer (since 0.14)
*)
(**/**)
(* for internal usage, do not use. There is no guarantee of stability. *)
module Private_ : sig
val parse_req_start :
client_addr:Unix.sockaddr ->
get_time_s:(unit -> float) ->
buf:Buf.t ->
IO.Input.t ->
unit t option resp_result
val parse_req_start_exn :
?buf:Buf.t ->
client_addr:Unix.sockaddr ->
get_time_s:(unit -> float) ->
IO.Input.t ->
unit t option
val close_after_req : _ t -> bool
val parse_body : ?bytes:bytes -> unit t -> IO.Input.t -> IO.Input.t t
val set_body : 'a -> _ t -> 'a t
end
(**/**)

164
src/core/response.ml Normal file
View file

@ -0,0 +1,164 @@
open Common_
type body =
[ `String of string | `Stream of IO.Input.t | `Writer of IO.Writer.t | `Void ]
type t = { code: Response_code.t; headers: Headers.t; body: body }
let set_body body self = { self with body }
let set_headers headers self = { self with headers }
let update_headers f self = { self with headers = f self.headers }
let set_header k v self = { self with headers = Headers.set k v self.headers }
let remove_header k self = { self with headers = Headers.remove k self.headers }
let set_code code self = { self with code }
let make_raw ?(headers = []) ~code body : t =
(* add content length to response *)
let headers =
Headers.set "Content-Length" (string_of_int (String.length body)) headers
in
{ code; headers; body = `String body }
let make_raw_stream ?(headers = []) ~code body : t =
let headers = Headers.set "Transfer-Encoding" "chunked" headers in
{ code; headers; body = `Stream body }
let make_raw_writer ?(headers = []) ~code body : t =
let headers = Headers.set "Transfer-Encoding" "chunked" headers in
{ code; headers; body = `Writer body }
let make_void_force_ ?(headers = []) ~code () : t =
{ code; headers; body = `Void }
let make_void ?(headers = []) ~code () : t =
let is_ok = code < 200 || code = 204 || code = 304 in
if is_ok then
make_void_force_ ~headers ~code ()
else
make_raw ~headers ~code "" (* invalid to not have a body *)
let make_string ?headers ?(code = 200) r =
match r with
| Ok body -> make_raw ?headers ~code body
| Error (code, msg) -> make_raw ?headers ~code msg
let make_stream ?headers ?(code = 200) r =
match r with
| Ok body -> make_raw_stream ?headers ~code body
| Error (code, msg) -> make_raw ?headers ~code msg
let make_writer ?headers ?(code = 200) r : t =
match r with
| Ok body -> make_raw_writer ?headers ~code body
| Error (code, msg) -> make_raw ?headers ~code msg
let make ?headers ?(code = 200) r : t =
match r with
| 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 =
Printf.ksprintf (fun msg -> make_raw ?headers ~code msg) fmt
exception Bad_req = Bad_req
let fail_raise ~code fmt =
Printf.ksprintf (fun msg -> raise (Bad_req (code, msg))) fmt
let pp out self : unit =
let pp_body out = function
| `String s -> Format.fprintf out "%S" s
| `Stream _ -> Format.pp_print_string out "<stream>"
| `Writer _ -> Format.pp_print_string out "<writer>"
| `Void -> ()
in
Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" self.code
Headers.pp self.headers pp_body self.body
let output_ ~bytes (oc : IO.Output.t) (self : t) : unit =
(* double indirection:
- print into [buffer] using [bprintf]
- transfer to [buf_] so we can output from there *)
let tmp_buffer = Buffer.create 32 in
let buf = Buf.of_bytes bytes in
(* write start of reply *)
Printf.bprintf tmp_buffer "HTTP/1.1 %d %s\r\n" self.code
(Response_code.descr self.code);
Buf.add_buffer buf tmp_buffer;
Buffer.clear tmp_buffer;
let body, is_chunked =
match self.body with
| `String s when String.length s > 1024 * 500 ->
(* chunk-encode large bodies *)
`Writer (IO.Writer.of_string s), true
| `String _ as b -> b, false
| `Stream _ as b -> b, true
| `Writer _ as b -> b, true
| `Void as b -> b, false
in
let headers =
if is_chunked then
self.headers
|> Headers.set "transfer-encoding" "chunked"
|> Headers.remove "content-length"
else
self.headers
in
let self = { self with headers; body } in
Log.debug (fun k ->
k "t[%d]: output response: %s"
(Thread.id @@ Thread.self ())
(Format.asprintf "%a" pp { self with body = `String "<...>" }));
(* write headers, using [buf] to batch writes *)
List.iter
(fun (k, v) ->
Printf.bprintf tmp_buffer "%s: %s\r\n" k v;
Buf.add_buffer buf tmp_buffer;
Buffer.clear tmp_buffer)
headers;
IO.Output.output_buf oc buf;
IO.Output.output_string oc "\r\n";
Buf.clear buf;
(match body with
| `String "" | `Void -> ()
| `String s -> IO.Output.output_string oc s
| `Writer w ->
(* use buffer to chunk encode [w] *)
let oc' = IO.Output.chunk_encoding ~buf ~close_rec:false oc in
(try
IO.Writer.write oc' w;
IO.Output.close oc'
with e ->
let bt = Printexc.get_raw_backtrace () in
IO.Output.close oc';
IO.Output.flush oc;
Printexc.raise_with_backtrace e bt)
| `Stream str ->
(match IO.Input.output_chunked' ~buf oc str with
| () ->
Log.debug (fun k ->
k "t[%d]: done outputing stream" (Thread.id @@ Thread.self ()));
IO.Input.close str
| exception e ->
let bt = Printexc.get_raw_backtrace () in
Log.error (fun k ->
k "t[%d]: outputing stream failed with %s"
(Thread.id @@ Thread.self ())
(Printexc.to_string e));
IO.Input.close str;
IO.Output.flush oc;
Printexc.raise_with_backtrace e bt));
IO.Output.flush oc
module Private_ = struct
let make_void_force_ = make_void_force_
let output_ = output_
end

122
src/core/response.mli Normal file
View file

@ -0,0 +1,122 @@
(** Responses
Responses are what a http server, such as {!Tiny_httpd}, send back to
the client to answer a {!Request.t}*)
type body =
[ `String of string | `Stream of IO.Input.t | `Writer of IO.Writer.t | `Void ]
(** Body of a response, either as a simple string,
or a stream of bytes, or nothing (for server-sent events notably).
- [`String str] replies with a body set to this string, and a known content-length.
- [`Stream str] replies with a body made from this string, using chunked encoding.
- [`Void] replies with no body.
- [`Writer w] replies with a body created by the writer [w], using
a chunked encoding.
It is available since 0.14.
*)
type t = private {
code: Response_code.t; (** HTTP response code. See {!Response_code}. *)
headers: Headers.t;
(** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *)
body: body; (** Body of the response. Can be empty. *)
}
(** A response to send back to a client. *)
val set_body : body -> t -> t
(** Set the body of the response.
@since 0.11 *)
val set_header : string -> string -> t -> t
(** Set a header.
@since 0.11 *)
val update_headers : (Headers.t -> Headers.t) -> t -> t
(** Modify headers.
@since 0.11 *)
val remove_header : string -> t -> t
(** Remove one instance of this header.
@since NEXT_RELEASE *)
val set_headers : Headers.t -> t -> t
(** Set all headers.
@since 0.11 *)
val set_code : Response_code.t -> t -> t
(** Set the response code.
@since 0.11 *)
val make_raw : ?headers:Headers.t -> code:Response_code.t -> string -> t
(** Make a response from its raw components, with a string body.
Use [""] to not send a body at all. *)
val make_raw_stream :
?headers:Headers.t -> code:Response_code.t -> IO.Input.t -> t
(** Same as {!make_raw} but with a stream body. The body will be sent with
the chunked transfer-encoding. *)
val make_void : ?headers:Headers.t -> code:int -> unit -> t
(** Return a response without a body at all.
@since 0.13 *)
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.
- [make (Error (code,msg))] replies with the given error code
and message as body.
*)
val make_string :
?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 ->
(IO.Writer.t, Response_code.t * string) result ->
t
(** Same as {!make} but with a writer body. *)
val make_stream :
?headers:Headers.t ->
?code:int ->
(IO.Input.t, Response_code.t * string) result ->
t
(** Same as {!make} but with a stream body. *)
val fail : ?headers:Headers.t -> code:int -> ('a, unit, string, t) format4 -> 'a
(** Make the current request fail with the given code and message.
Example: [fail ~code:404 "oh noes, %s not found" "waldo"].
*)
exception Bad_req of int * string
(** Exception raised by {!fail_raise} with the HTTP code and body *)
val fail_raise : code:int -> ('a, unit, string, 'b) format4 -> 'a
(** Similar to {!fail} but raises an exception that exits the current handler.
This should not be used outside of a (path) handler.
Example: [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
@raise Bad_req always
*)
val pp : Format.formatter -> t -> unit
(** Pretty print the response. The exact format is not specified. *)
(**/**)
module Private_ : sig
val make_void_force_ : ?headers:Headers.t -> code:int -> unit -> t
val output_ : bytes:Bytes.t -> IO.Output.t -> t -> unit
end
(**/**)

32
src/core/response_code.ml Normal file
View file

@ -0,0 +1,32 @@
type t = int
let ok = 200
let not_found = 404
let descr = function
| 100 -> "Continue"
| 200 -> "OK"
| 201 -> "Created"
| 202 -> "Accepted"
| 204 -> "No content"
| 300 -> "Multiple choices"
| 301 -> "Moved permanently"
| 302 -> "Found"
| 304 -> "Not Modified"
| 400 -> "Bad request"
| 401 -> "Unauthorized"
| 403 -> "Forbidden"
| 404 -> "Not found"
| 405 -> "Method not allowed"
| 408 -> "Request timeout"
| 409 -> "Conflict"
| 410 -> "Gone"
| 411 -> "Length required"
| 413 -> "Payload too large"
| 417 -> "Expectation failed"
| 500 -> "Internal server error"
| 501 -> "Not implemented"
| 503 -> "Service unavailable"
| n -> "Unknown response code " ^ string_of_int n (* TODO *)
let[@inline] is_success n = n >= 200 && n < 400

20
src/core/response_code.mli Normal file
View file

@ -0,0 +1,20 @@
(** Response Codes *)
type t = int
(** A standard HTTP code.
https://tools.ietf.org/html/rfc7231#section-6 *)
val ok : t
(** The code [200] *)
val not_found : t
(** The code [404] *)
val descr : t -> string
(** A description of some of the error codes.
NOTE: this is not complete (yet). *)
val is_success : t -> bool
(** [is_success code] is true iff [code] is in the [2xx] or [3xx] range.
@since NEXT_RELEASE *)

93
src/core/route.ml Normal file
View file

@ -0,0 +1,93 @@
type path = string list (* split on '/' *)
type (_, _) comp =
| Exact : string -> ('a, 'a) comp
| Int : (int -> 'a, 'a) comp
| String : (string -> 'a, 'a) comp
| String_urlencoded : (string -> 'a, 'a) comp
type (_, _) t =
| Fire : ('b, 'b) t
| Rest : { url_encoded: bool } -> (string -> 'b, 'b) t
| Compose : ('a, 'b) comp * ('b, 'c) t -> ('a, 'c) t
let return = Fire
let rest_of_path = Rest { url_encoded = false }
let rest_of_path_urlencoded = Rest { url_encoded = true }
let ( @/ ) a b = Compose (a, b)
let string = String
let string_urlencoded = String_urlencoded
let int = Int
let exact (s : string) = Exact s
let exact_path (s : string) tail =
let rec fn = function
| [] -> tail
| "" :: ls -> fn ls
| s :: ls -> exact s @/ fn ls
in
fn (String.split_on_char '/' s)
let rec eval : type a b. path -> (a, b) t -> a -> b option =
fun path route f ->
match path, route with
| [], Fire -> Some f
| _, Fire -> None
| _, Rest { url_encoded } ->
let whole_path = String.concat "/" path in
(match
if url_encoded then (
match Util.percent_decode whole_path with
| Some s -> s
| None -> raise_notrace Exit
) else
whole_path
with
| whole_path -> Some (f whole_path)
| exception Exit -> None)
| c1 :: path', Compose (comp, route') ->
(match comp with
| Int ->
(match int_of_string c1 with
| i -> eval path' route' (f i)
| exception _ -> None)
| String -> eval path' route' (f c1)
| String_urlencoded ->
(match Util.percent_decode c1 with
| None -> None
| Some s -> eval path' route' (f s))
| Exact s ->
if s = c1 then
eval path' route' f
else
None)
| [], Compose (String, Fire) -> Some (f "") (* trailing *)
| [], Compose (String_urlencoded, Fire) -> Some (f "") (* trailing *)
| [], Compose _ -> None
let bpf = Printf.bprintf
let rec pp_ : type a b. Buffer.t -> (a, b) t -> unit =
fun out -> function
| Fire -> bpf out "/"
| Rest { url_encoded } ->
bpf out "<rest_of_url%s>"
(if url_encoded then
"_urlencoded"
else
"")
| Compose (Exact s, tl) -> bpf out "%s/%a" s pp_ tl
| Compose (Int, tl) -> bpf out "<int>/%a" pp_ tl
| Compose (String, tl) -> bpf out "<str>/%a" pp_ tl
| Compose (String_urlencoded, tl) -> bpf out "<enc_str>/%a" pp_ tl
let to_string x =
let b = Buffer.create 16 in
pp_ b x;
Buffer.contents b
module Private_ = struct
let eval = eval
end
let pp out x = Format.pp_print_string out (to_string x)

58
src/core/route.mli Normal file
View file

@ -0,0 +1,58 @@
(** Routing
Basic type-safe routing of handlers based on URL paths. This is optional,
it is possible to only define the root handler with something like
{{: https://github.com/anuragsoni/routes/} Routes}.
@since 0.6 *)
type ('a, 'b) comp
(** An atomic component of a path *)
type ('a, 'b) t
(** A route, composed of path components *)
val int : (int -> 'a, 'a) comp
(** Matches an integer. *)
val string : (string -> 'a, 'a) comp
(** Matches a string not containing ['/'] and binds it as is. *)
val string_urlencoded : (string -> 'a, 'a) comp
(** Matches a URL-encoded string, and decodes it. *)
val exact : string -> ('a, 'a) comp
(** [exact "s"] matches ["s"] and nothing else. *)
val return : ('a, 'a) t
(** Matches the empty path. *)
val rest_of_path : (string -> 'a, 'a) t
(** Matches a string, even containing ['/']. This will match
the entirety of the remaining route.
@since 0.7 *)
val rest_of_path_urlencoded : (string -> 'a, 'a) t
(** Matches a string, even containing ['/'], an URL-decode it.
This will match the entirety of the remaining route.
@since 0.7 *)
val ( @/ ) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t
(** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"],
and [route] matches ["bar/…"]. *)
val exact_path : string -> ('a, 'b) t -> ('a, 'b) t
(** [exact_path "foo/bar/..." r] is equivalent to
[exact "foo" @/ exact "bar" @/ ... @/ r]
@since 0.11 **)
val pp : Format.formatter -> _ t -> unit
(** Print the route.
@since 0.7 *)
val to_string : _ t -> string
(** Print the route.
@since 0.7 *)
module Private_ : sig
val eval : string list -> ('a, 'b) t -> 'a -> 'b option
end

514
src/core/server.ml Normal file
View file

@ -0,0 +1,514 @@
open Common_
type resp_error = Response_code.t * string
module Middleware = struct
type handler = IO.Input.t Request.t -> resp:(Response.t -> unit) -> unit
type t = handler -> handler
(** Apply a list of middlewares to [h] *)
let apply_l (l : t list) (h : handler) : handler =
List.fold_right (fun m h -> m h) l h
let[@inline] nil : t = fun h -> h
end
(* a request handler. handles a single request. *)
type cb_path_handler = IO.Output.t -> Middleware.handler
module type SERVER_SENT_GENERATOR = sig
val set_headers : Headers.t -> unit
val send_event :
?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
val close : unit -> unit
end
type server_sent_generator = (module SERVER_SENT_GENERATOR)
(** Handler that upgrades to another protocol *)
module type UPGRADE_HANDLER = sig
type handshake_state
(** Some specific state returned after handshake *)
val name : string
(** Name in the "upgrade" header *)
val handshake : unit Request.t -> (Headers.t * handshake_state, string) result
(** Perform the handshake and upgrade the connection. The returned
code is [101] alongside these headers. *)
val handle_connection :
Unix.sockaddr -> handshake_state -> IO.Input.t -> IO.Output.t -> unit
(** Take control of the connection and take it from there *)
end
type upgrade_handler = (module UPGRADE_HANDLER)
exception Upgrade of unit Request.t * upgrade_handler
module type IO_BACKEND = sig
val init_addr : unit -> string
val init_port : unit -> int
val get_time_s : unit -> float
(** obtain the current timestamp in seconds. *)
val tcp_server : unit -> IO.TCP_server.builder
(** Server that can listen on a port and handle clients. *)
end
type handler_result =
| Handle of (int * Middleware.t) list * cb_path_handler
| Fail of resp_error
| Upgrade of upgrade_handler
let unwrap_handler_result req = function
| Handle (l, h) -> l, h
| Fail (c, s) -> raise (Bad_req (c, s))
| Upgrade up -> raise (Upgrade (req, up))
type t = {
backend: (module IO_BACKEND);
mutable tcp_server: IO.TCP_server.t option;
mutable handler: IO.Input.t Request.t -> Response.t;
(** toplevel handler, if any *)
mutable middlewares: (int * Middleware.t) list; (** Global middlewares *)
mutable middlewares_sorted: (int * Middleware.t) list lazy_t;
(** sorted version of {!middlewares} *)
mutable path_handlers: (unit Request.t -> handler_result option) list;
(** path handlers *)
bytes_pool: bytes Pool.t;
}
let addr (self : t) =
match self.tcp_server with
| None ->
let (module B) = self.backend in
B.init_addr ()
| Some s -> fst @@ s.endpoint ()
let port (self : t) =
match self.tcp_server with
| None ->
let (module B) = self.backend in
B.init_port ()
| Some s -> snd @@ s.endpoint ()
let active_connections (self : t) =
match self.tcp_server with
| None -> 0
| Some s -> s.active_connections ()
let sort_middlewares_ l =
List.stable_sort (fun (s1, _) (s2, _) -> compare s1 s2) l
let add_middleware ~stage self m =
let stage =
match stage with
| `Encoding -> 0
| `Stage n when n < 1 -> invalid_arg "add_middleware: bad stage"
| `Stage n -> n
in
self.middlewares <- (stage, m) :: self.middlewares;
self.middlewares_sorted <- lazy (sort_middlewares_ self.middlewares)
let add_decode_request_cb self f =
(* turn it into a middleware *)
let m h req ~resp =
(* see if [f] modifies the stream *)
let req0 = Request.Private_.set_body () req in
match f req0 with
| None -> h req ~resp (* pass through *)
| Some (req1, tr_stream) ->
let body = tr_stream req.Request.body in
let req = Request.set_body body req1 in
h req ~resp
in
add_middleware self ~stage:`Encoding m
let add_encode_response_cb self f =
let m h req ~resp =
h req ~resp:(fun r ->
let req0 = Request.Private_.set_body () req in
(* now transform [r] if we want to *)
match f req0 r with
| None -> resp r
| Some r' -> resp r')
in
add_middleware self ~stage:`Encoding m
let set_top_handler self f = self.handler <- f
(* route the given handler.
@param tr_req wraps the actual concrete function returned by the route
and makes it into a handler. *)
let add_route_handler_ ?(accept = fun _req -> Ok ()) ?(middlewares = []) ?meth
~tr_req self (route : _ Route.t) f =
let middlewares = List.map (fun h -> 5, h) middlewares in
let ph req : handler_result option =
match meth with
| Some m when m <> req.Request.meth -> None (* ignore *)
| _ ->
(match Route.Private_.eval req.Request.path_components route f with
| Some handler ->
(* we have a handler, do we accept the request based on its headers? *)
(match accept req with
| Ok () ->
Some
(Handle
(middlewares, fun oc req ~resp -> tr_req oc req ~resp handler))
| Error err -> Some (Fail err))
| None -> None (* path didn't match *))
in
self.path_handlers <- ph :: self.path_handlers
let add_route_handler (type a) ?accept ?middlewares ?meth self
(route : (a, _) Route.t) (f : _) : unit =
let tr_req _oc req ~resp f =
let req =
Pool.with_resource self.bytes_pool @@ fun bytes ->
Request.read_body_full ~bytes req
in
resp (f req)
in
add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f
let add_route_handler_stream ?accept ?middlewares ?meth self route f =
let tr_req _oc req ~resp f = resp (f req) in
add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f
let[@inline] _opt_iter ~f o =
match o with
| None -> ()
| Some x -> f x
exception Exit_SSE
let add_route_server_sent_handler ?accept self route f =
let tr_req (oc : IO.Output.t) req ~resp f =
let req =
Pool.with_resource self.bytes_pool @@ fun bytes ->
Request.read_body_full ~bytes req
in
let headers =
ref Headers.(empty |> set "content-type" "text/event-stream")
in
(* send response once *)
let resp_sent = ref false in
let send_response_idempotent_ () =
if not !resp_sent then (
resp_sent := true;
(* send 200 response now *)
let initial_resp =
Response.Private_.make_void_force_ ~headers:!headers ~code:200 ()
in
resp initial_resp
)
in
let[@inline] writef fmt =
Printf.ksprintf (IO.Output.output_string oc) fmt
in
let send_event ?event ?id ?retry ~data () : unit =
send_response_idempotent_ ();
_opt_iter event ~f:(fun e -> writef "event: %s\n" e);
_opt_iter id ~f:(fun e -> writef "id: %s\n" e);
_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.Output.output_string oc "\n";
(* finish group *)
IO.Output.flush oc
in
let module SSG = struct
let set_headers h =
if not !resp_sent then (
headers := List.rev_append h !headers;
send_response_idempotent_ ()
)
let send_event = send_event
let close () = raise Exit_SSE
end in
(try f req (module SSG : SERVER_SENT_GENERATOR)
with Exit_SSE -> IO.Output.close oc);
Log.info (fun k -> k "closed SSE connection")
in
add_route_handler_ self ?accept ~meth:`GET route ~tr_req f
let add_upgrade_handler ?(accept = fun _ -> Ok ()) (self : t) route f : unit =
let ph req : handler_result option =
if req.Request.meth <> `GET then
None
else (
match accept req with
| Ok () ->
(match Route.Private_.eval req.Request.path_components route f with
| Some up -> Some (Upgrade up)
| None -> None (* path didn't match *))
| Error err -> Some (Fail err)
)
in
self.path_handlers <- ph :: self.path_handlers
let clear_bytes_ bs = Bytes.fill bs 0 (Bytes.length bs) '\x00'
let create_from ?(buf_size = 16 * 1_024) ?(middlewares = []) ~backend () : t =
let handler _req = Response.fail ~code:404 "no top handler" in
let self =
{
backend;
tcp_server = None;
handler;
path_handlers = [];
middlewares = [];
middlewares_sorted = lazy [];
bytes_pool =
Pool.create ~clear:clear_bytes_
~mk_item:(fun () -> Bytes.create buf_size)
();
}
in
List.iter (fun (stage, m) -> add_middleware self ~stage m) middlewares;
self
let stop (self : t) =
match self.tcp_server with
| None -> ()
| Some s -> s.stop ()
let running (self : t) =
match self.tcp_server with
| None -> false
| Some s -> s.running ()
let find_map f l =
let rec aux f = function
| [] -> None
| x :: l' ->
(match f x with
| Some _ as res -> res
| None -> aux f l')
in
aux f l
let string_as_list_contains_ (s : string) (sub : string) : bool =
let fragments = String.split_on_char ',' s in
List.exists (fun fragment -> String.trim fragment = sub) fragments
(* handle client on [ic] and [oc] *)
let client_handle_for (self : t) ~client_addr ic oc : unit =
Pool.with_resource self.bytes_pool @@ fun bytes_req ->
Pool.with_resource self.bytes_pool @@ fun bytes_res ->
let (module B) = self.backend in
(* how to log the response to this query *)
let log_response (req : _ Request.t) (resp : Response.t) =
if not Log.dummy then (
let msgf k =
let elapsed = B.get_time_s () -. req.start_time in
k
("response to=%s code=%d time=%.3fs meth=%s path=%S" : _ format4)
(Util.show_sockaddr client_addr)
resp.code elapsed (Meth.to_string req.meth) req.path
in
if Response_code.is_success resp.code then
Log.info msgf
else
Log.error msgf
)
in
let log_exn msg bt =
Log.error (fun k ->
k "error while processing response for %s msg=%s@.%s"
(Util.show_sockaddr client_addr)
msg
(Printexc.raw_backtrace_to_string bt))
in
(* handle generic exception *)
let handle_exn e bt : unit =
let msg = Printexc.to_string e in
let resp = Response.fail ~code:500 "server error: %s" msg in
if not Log.dummy then log_exn msg bt;
Response.Private_.output_ ~bytes:bytes_res oc resp
in
let handle_bad_req req e bt =
let msg = Printexc.to_string e in
let resp = Response.fail ~code:500 "server error: %s" msg in
if not Log.dummy then (
log_exn msg bt;
log_response req resp
);
Response.Private_.output_ ~bytes:bytes_res oc resp
in
let handle_upgrade req (module UP : UPGRADE_HANDLER) : unit =
Log.debug (fun k -> k "upgrade connection");
try
(* check headers *)
(match Request.get_header req "connection" with
| Some str when string_as_list_contains_ str "Upgrade" -> ()
| _ -> bad_reqf 426 "connection header must contain 'Upgrade'");
(match Request.get_header req "upgrade" with
| Some u when u = UP.name -> ()
| Some u -> bad_reqf 426 "expected upgrade to be '%s', got '%s'" UP.name u
| None -> bad_reqf 426 "expected 'connection: upgrade' header");
(* ok, this is the upgrade we expected *)
match UP.handshake req with
| Error msg ->
(* fail the upgrade *)
Log.error (fun k -> k "upgrade failed: %s" msg);
let resp = Response.make_raw ~code:429 "upgrade required" in
log_response req resp;
Response.Private_.output_ ~bytes:bytes_res oc resp
| Ok (headers, handshake_st) ->
(* send the upgrade reply *)
let headers =
[ "connection", "upgrade"; "upgrade", UP.name ] @ headers
in
let resp = Response.make_string ~code:101 ~headers (Ok "") in
log_response req resp;
Response.Private_.output_ ~bytes:bytes_res oc resp;
UP.handle_connection client_addr handshake_st ic oc
with e ->
let bt = Printexc.get_raw_backtrace () in
handle_bad_req req e bt
in
let continue = ref true in
let handle_one_req () =
match
let buf = Buf.of_bytes bytes_req in
Request.Private_.parse_req_start ~client_addr ~get_time_s:B.get_time_s
~buf ic
with
| Ok None -> continue := false (* client is done *)
| Error (c, s) ->
(* connection error, close *)
let res = Response.make_raw ~code:c s in
(try Response.Private_.output_ ~bytes:bytes_res oc res
with Sys_error _ -> ());
continue := false
| Ok (Some req) ->
Log.debug (fun k ->
k "t[%d]: parsed request: %s"
(Thread.id @@ Thread.self ())
(Format.asprintf "@[%a@]" Request.pp_ req));
if Request.Private_.close_after_req req then continue := false;
(try
(* is there a handler for this path? *)
let handler_middlewares, base_handler =
match find_map (fun ph -> ph req) self.path_handlers with
| Some f -> unwrap_handler_result req f
| None -> [], fun _oc req ~resp -> resp (self.handler req)
in
(* handle expect/continue *)
(match Request.get_header ~f:String.trim req "Expect" with
| Some "100-continue" ->
Log.debug (fun k -> k "send back: 100 CONTINUE");
Response.Private_.output_ ~bytes:bytes_res oc
(Response.make_raw ~code:100 "")
| Some s -> bad_reqf 417 "unknown expectation %s" s
| None -> ());
(* merge per-request middlewares with the server-global middlewares *)
let global_middlewares = Lazy.force self.middlewares_sorted in
let all_middlewares =
if handler_middlewares = [] then
global_middlewares
else
sort_middlewares_
(List.rev_append handler_middlewares self.middlewares)
in
(* apply middlewares *)
let handler oc =
List.fold_right
(fun (_, m) h -> m h)
all_middlewares (base_handler oc)
in
(* now actually read request's body into a stream *)
let req = Request.Private_.parse_body ~bytes:bytes_req req ic in
(* how to reply *)
let resp r =
try
if Headers.get "connection" r.Response.headers = Some "close" then
continue := false;
log_response req r;
Response.Private_.output_ ~bytes:bytes_res oc r
with Sys_error e ->
Log.debug (fun k ->
k "error when writing response: %s@.connection broken" e);
continue := false
in
(* call handler *)
try handler oc req ~resp
with Sys_error e ->
Log.debug (fun k ->
k "error while handling request: %s@.connection broken" e);
continue := false
with
| Sys_error e ->
(* connection broken somehow *)
Log.debug (fun k -> k "error: %s@. connection broken" e);
continue := false
| Bad_req (code, s) ->
continue := false;
let resp = Response.make_raw ~code s in
log_response req resp;
Response.Private_.output_ ~bytes:bytes_res oc resp
| Upgrade _ as e -> raise e
| e ->
let bt = Printexc.get_raw_backtrace () in
handle_bad_req req e bt)
in
try
while !continue && running self do
Log.debug (fun k ->
k "t[%d]: read next request" (Thread.id @@ Thread.self ()));
handle_one_req ()
done
with
| Upgrade (req, up) ->
(* upgrades take over the whole connection, we won't process
any further request *)
handle_upgrade req up
| e ->
let bt = Printexc.get_raw_backtrace () in
handle_exn e bt
let client_handler (self : t) : IO.TCP_server.conn_handler =
{ IO.TCP_server.handle = client_handle_for self }
let is_ipv6 (self : t) =
let (module B) = self.backend in
Util.is_ipv6_str (B.init_addr ())
let run_exn ?(after_init = ignore) (self : t) : unit =
let (module B) = self.backend in
let server = B.tcp_server () in
server.serve
~after_init:(fun tcp_server ->
self.tcp_server <- Some tcp_server;
after_init ())
~handle:(client_handler self) ()
let run ?after_init self : _ result =
try Ok (run_exn ?after_init self) with e -> Error e

298
src/core/server.mli Normal file
View file

@ -0,0 +1,298 @@
(** HTTP server.
This module implements a very simple, basic HTTP/1.1 server using blocking
IOs and threads.
It is possible to use a thread pool, see {!create}'s argument [new_thread].
@since 0.13
*)
(** {2 Middlewares}
A middleware can be inserted in a handler to modify or observe
its behavior.
@since 0.11
*)
module Middleware : sig
type handler = IO.Input.t Request.t -> resp:(Response.t -> unit) -> unit
(** Handlers are functions returning a response to a request.
The response can be delayed, hence the use of a continuation
as the [resp] parameter. *)
type t = handler -> handler
(** A middleware is a handler transformation.
It takes the existing handler [h],
and returns a new one which, given a query, modify it or log it
before passing it to [h], or fail. It can also log or modify or drop
the response. *)
val nil : t
(** Trivial middleware that does nothing. *)
end
(** {2 Main Server type} *)
type t
(** A HTTP server. See {!create} for more details. *)
(** A backend that provides IO operations, network operations, etc.
This is used to decouple tiny_httpd from the scheduler/IO library used to
actually open a TCP server and talk to clients. The classic way is
based on {!Unix} and blocking IOs, but it's also possible to
use an OCaml 5 library using effects and non blocking IOs. *)
module type IO_BACKEND = sig
val init_addr : unit -> string
(** Initial TCP address *)
val init_port : unit -> int
(** Initial port *)
val get_time_s : unit -> float
(** Obtain the current timestamp in seconds. *)
val tcp_server : unit -> IO.TCP_server.builder
(** TCP server builder, to create servers that can listen
on a port and handle clients. *)
end
val create_from :
?buf_size:int ->
?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
backend:(module IO_BACKEND) ->
unit ->
t
(** Create a new webserver using provided backend.
The server will not do anything until {!run} is called on it.
Before starting the server, one can use {!add_path_handler} and
{!set_top_handler} to specify how to handle incoming requests.
@param buf_size size for buffers (since 0.11)
@param middlewares see {!add_middleware} for more details.
@since 0.14
*)
val addr : t -> string
(** Address on which the server listens. *)
val is_ipv6 : t -> bool
(** [is_ipv6 server] returns [true] iff the address of the server is an IPv6 address.
@since 0.3 *)
val port : t -> int
(** Port on which the server listens. Note that this might be different than
the port initially given if the port was [0] (meaning that the OS picks a
port for us). *)
val active_connections : t -> int
(** Number of currently active connections. *)
val add_decode_request_cb :
t ->
(unit Request.t -> (unit Request.t * (IO.Input.t -> IO.Input.t)) option) ->
unit
[@@deprecated "use add_middleware"]
(** Add a callback for every request.
The callback can provide a stream transformer and a new request (with
modified headers, typically).
A possible use is to handle decompression by looking for a [Transfer-Encoding]
header and returning a stream transformer that decompresses on the fly.
@deprecated use {!add_middleware} instead
*)
val add_encode_response_cb :
t -> (unit Request.t -> Response.t -> Response.t option) -> unit
[@@deprecated "use add_middleware"]
(** Add a callback for every request/response pair.
Similarly to {!add_encode_response_cb} the callback can return a new
response, for example to compress it.
The callback is given the query with only its headers,
as well as the current response.
@deprecated use {!add_middleware} instead
*)
val add_middleware :
stage:[ `Encoding | `Stage of int ] -> t -> Middleware.t -> unit
(** Add a middleware to every request/response pair.
@param stage specify when middleware applies.
Encoding comes first (outermost layer), then stages in increasing order.
@raise Invalid_argument if stage is [`Stage n] where [n < 1]
@since 0.11
*)
(** {2 Request handlers} *)
val set_top_handler : t -> (IO.Input.t Request.t -> Response.t) -> unit
(** Setup a handler called by default.
This handler is called with any request not accepted by any handler
installed via {!add_path_handler}.
If no top handler is installed, unhandled paths will return a [404] not found
This used to take a [string Request.t] but it now takes a [byte_stream Request.t]
since 0.14 . Use {!Request.read_body_full} to read the body into
a string if needed.
*)
val add_route_handler :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
?middlewares:Middleware.t list ->
?meth:Meth.t ->
t ->
('a, string Request.t -> Response.t) Route.t ->
'a ->
unit
(** [add_route_handler server Route.(exact "path" @/ string @/ int @/ return) f]
calls [f "foo" 42 request] when a [request] with path "path/foo/42/"
is received.
Note that the handlers are called in the reverse order of their addition,
so the last registered handler can override previously registered ones.
@param meth if provided, only accept requests with the given method.
Typically one could react to [`GET] or [`PUT].
@param accept should return [Ok()] if the given request (before its body
is read) should be accepted, [Error (code,message)] if it's to be rejected (e.g. because
its content is too big, or for some permission error).
See the {!http_of_dir} program for an example of how to use [accept] to
filter uploads that are too large before the upload even starts.
The default always returns [Ok()], i.e. it accepts all requests.
@since 0.6
*)
val add_route_handler_stream :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
?middlewares:Middleware.t list ->
?meth:Meth.t ->
t ->
('a, IO.Input.t Request.t -> Response.t) Route.t ->
'a ->
unit
(** Similar to {!add_route_handler}, but where the body of the request
is a stream of bytes that has not been read yet.
This is useful when one wants to stream the body directly into a parser,
json decoder (such as [Jsonm]) or into a file.
@since 0.6 *)
(** {2 Server-sent events}
{b EXPERIMENTAL}: this API is not stable yet. *)
(** A server-side function to generate of Server-sent events.
See {{: https://html.spec.whatwg.org/multipage/server-sent-events.html} the w3c page}
and {{: https://jvns.ca/blog/2021/01/12/day-36--server-sent-events-are-cool--and-a-fun-bug/}
this blog post}.
@since 0.9
*)
module type SERVER_SENT_GENERATOR = sig
val set_headers : Headers.t -> unit
(** Set headers of the response.
This is not mandatory but if used at all, it must be called before
any call to {!send_event} (once events are sent the response is
already sent too). *)
val send_event :
?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
(** Send an event from the server.
If data is a multiline string, it will be sent on separate "data:" lines. *)
val close : unit -> unit
(** Close connection.
@since 0.11 *)
end
type server_sent_generator = (module SERVER_SENT_GENERATOR)
(** Server-sent event generator. This generates events that are forwarded to
the client (e.g. the browser).
@since 0.9 *)
val add_route_server_sent_handler :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
t ->
('a, string Request.t -> server_sent_generator -> unit) Route.t ->
'a ->
unit
(** Add a handler on an endpoint, that serves server-sent events.
The callback is given a generator that can be used to send events
as it pleases. The connection is always closed by the client,
and the accepted method is always [GET].
This will set the header "content-type" to "text/event-stream" automatically
and reply with a 200 immediately.
See {!server_sent_generator} for more details.
This handler stays on the original thread (it is synchronous).
@since 0.9 *)
(** {2 Upgrade handlers}
These handlers upgrade the connection to another protocol.
@since NEXT_RELEASE *)
(** Handler that upgrades to another protocol.
@since NEXT_RELEASE *)
module type UPGRADE_HANDLER = sig
type handshake_state
(** Some specific state returned after handshake *)
val name : string
(** Name in the "upgrade" header *)
val handshake : unit Request.t -> (Headers.t * handshake_state, string) result
(** Perform the handshake and upgrade the connection. The returned
code is [101] alongside these headers.
In case the handshake fails, this only returns [Error log_msg].
The connection is closed without further ado. *)
val handle_connection :
Unix.sockaddr -> handshake_state -> IO.Input.t -> IO.Output.t -> unit
(** Take control of the connection and take it from ther.e *)
end
type upgrade_handler = (module UPGRADE_HANDLER)
(** @since NEXT_RELEASE *)
val add_upgrade_handler :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
t ->
('a, upgrade_handler) Route.t ->
'a ->
unit
(** {2 Run the server} *)
val running : t -> bool
(** Is the server running?
@since 0.14 *)
val stop : t -> unit
(** Ask the server to stop. This might not have an immediate effect
as {!run} might currently be waiting on IO. *)
val run : ?after_init:(unit -> unit) -> t -> (unit, exn) result
(** Run the main loop of the server, listening on a socket
described at the server's creation time, using [new_thread] to
start a thread for each new client.
This returns [Ok ()] if the server exits gracefully, or [Error e] if
it exits with an error.
@param after_init is called after the server starts listening. since 0.13 .
*)
val run_exn : ?after_init:(unit -> unit) -> t -> unit
(** [run_exn s] is like [run s] but re-raises an exception if the server exits
with an error.
@since 0.14 *)

32
src/Tiny_httpd_stream.ml → src/core/stream.ml.tmp
View file

@ -1,3 +1,4 @@
(*
module Buf = Tiny_httpd_buf
module IO = Tiny_httpd_io
@ -184,36 +185,6 @@ let read_line_into (self : t) ~buf : unit =
)
done
(* new stream with maximum size [max_size].
@param close_rec if true, closing this will also close the input stream
@param too_big called with read size if the max size is reached *)
let limit_size_to ~close_rec ~max_size ~too_big (arg : t) : t =
let size = ref 0 in
let continue = ref true in
make ~bs:Bytes.empty
~close:(fun _ -> if close_rec then arg.close ())
~fill:(fun res ->
if res.len = 0 && !continue then (
arg.fill_buf ();
res.bs <- arg.bs;
res.off <- arg.off;
res.len <- arg.len
) else (
arg.bs <- Bytes.empty;
arg.off <- 0;
arg.len <- 0
))
~consume:(fun res n ->
size := !size + n;
if !size > max_size then (
continue := false;
too_big !size
) else (
arg.consume n;
res.off <- res.off + n;
res.len <- res.len - n
))
()
(* read exactly [size] bytes from the stream *)
let read_exactly ~close_rec ~size ~too_short (arg : t) : t =
@ -320,3 +291,4 @@ let output_chunked' ?buf (oc : IO.Output.t) (self : t) : unit =
(* print a stream as a series of chunks *)
let output_chunked ?buf (oc : out_channel) (self : t) : unit =
output_chunked' ?buf (IO.Output.of_out_channel oc) self
*)

2
src/Tiny_httpd_stream.mli → src/core/stream.mli.tmp
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.Input.t -> t
val of_input : ?buf_size:int -> Io.Input.t -> t
(** Make a buffered stream from the given channel.
@since 0.14 *)

8
src/Tiny_httpd_util.ml → src/core/util.ml
View file

@ -76,6 +76,12 @@ let split_on_slash s : _ list =
List.rev !l
let parse_query s : (_ list, string) result =
let s =
(* skip hash if present *)
match String.index_opt s '#' with
| Some i -> String.sub s (i + 1) (String.length s - i - 1)
| None -> s
in
let pairs = ref [] in
let is_sep_ = function
| '&' | ';' -> true
@ -119,3 +125,5 @@ let show_sockaddr = function
| Unix.ADDR_UNIX f -> f
| Unix.ADDR_INET (inet, port) ->
Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet) port
let is_ipv6_str addr : bool = String.contains addr ':'

4
src/Tiny_httpd_util.mli → src/core/util.mli
View file

@ -38,3 +38,7 @@ val parse_query : string -> ((string * string) list, string) result
val show_sockaddr : Unix.sockaddr -> string
(** Simple printer for socket addresses.
@since NEXT_RELEASE *)
val is_ipv6_str : string -> bool
(** Is this string potentially an IPV6 address?
@since NEXT_RELEASE *)

30
src/dune
View file

@ -1,30 +1,6 @@
(library
(name tiny_httpd)
(public_name tiny_httpd)
(private_modules Tiny_httpd_mime_ Tiny_httpd_parse_)
(libraries threads seq unix
(select Tiny_httpd_mime_.ml from
(magic-mime -> Tiny_httpd_mime_.magic.ml)
( -> Tiny_httpd_mime_.dummy.ml))
(select Tiny_httpd_log.ml from
(logs logs.fmt fmt.tty -> Tiny_httpd_log.logs.ml)
(-> Tiny_httpd_log.default.ml)))
(wrapped false))
(rule
(targets Tiny_httpd_html_.ml)
(deps
(:bin ./gen/gentags.exe))
(action
(with-stdout-to
%{targets}
(run %{bin}))))
(rule
(targets Tiny_httpd_atomic_.ml)
(deps
(:bin ./gen/mkshims.exe))
(action
(with-stdout-to
%{targets}
(run %{bin}))))
(flags :standard -open Tiny_httpd_core)
(libraries threads seq unix hmap tiny_httpd.core tiny_httpd.html
tiny_httpd.unix))

2
src/gen/dune
View file

@ -1,2 +0,0 @@
(executables
(names gentags mkshims))

12
src/Tiny_httpd_html.ml → src/html/Tiny_httpd_html.ml
View file

@ -6,9 +6,7 @@
@since 0.12
*)
module IO = Tiny_httpd_io
include Tiny_httpd_html_
include Html_
(** @inline *)
(** Write an HTML element to this output.
@ -16,7 +14,7 @@ include Tiny_httpd_html_
be a "html" tag.
@since 0.14
*)
let to_output ?(top = false) (self : elt) (out : IO.Output.t) : unit =
let to_output ?(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;
@ -56,10 +54,10 @@ let to_out_channel_top = to_output ~top:true
@param top if true, add a DOCTYPE. See {!to_out_channel}.
@since 0.14 *)
let to_writer ?top (self : elt) : IO.Writer.t =
let write oc = to_output ?top self oc in
let write (oc : #IO.Output.t) = to_output ?top self oc in
IO.Writer.make ~write ()
(** Convert a HTML element to a stream. This might just convert
it to a string first, do not assume it to be more efficient. *)
let to_stream (self : elt) : Tiny_httpd_stream.t =
Tiny_httpd_stream.of_string @@ to_string self
let[@inline] to_stream (self : elt) : IO.Input.t =
IO.Input.of_string @@ to_string self

16
src/html/dune Normal file
View file

@ -0,0 +1,16 @@
(library
(name tiny_httpd_html)
(public_name tiny_httpd.html)
(flags :standard -open Tiny_httpd_core)
(libraries seq tiny_httpd.core))
(rule
(targets html_.ml)
(deps
(:bin ./gen/gentags.exe))
(action
(with-stdout-to
%{targets}
(run %{bin}))))

2
src/html/gen/dune Normal file
View file

@ -0,0 +1,2 @@
(executables
(names gentags))

3
src/gen/gentags.ml → src/html/gen/gentags.ml
View file

@ -294,14 +294,13 @@ let prelude =
module Out : sig
type t
val create_of_buffer : Buffer.t -> t
val create_of_out: Tiny_httpd_io.Output.t -> t
val create_of_out: IO.Output.t -> t
val flush : t -> unit
val add_char : t -> char -> unit
val add_string : t -> string -> unit
val add_format_nl : t -> unit
val with_no_format_nl : t -> (unit -> 'a) -> 'a
end = struct
module IO = Tiny_httpd_io
type t = {
out: IO.Output.t;
mutable fmt_nl: bool; (* if true, we print [\n] around tags to format the html *)

3
src/prometheus/common_.ml
View file

@ -1,3 +0,0 @@
module A = Tiny_httpd_atomic_
let spf = Printf.sprintf

3
src/prometheus/common_p_.ml Normal file
View file

@ -0,0 +1,3 @@
module A = Tiny_httpd_core.Atomic_
let spf = Printf.sprintf

5
src/prometheus/dune
View file

@ -4,9 +4,10 @@
(name tiny_httpd_prometheus)
(public_name tiny_httpd.prometheus)
(synopsis "Metrics using prometheus")
(private_modules common_ time_)
(private_modules common_p_ time_)
(flags :standard -open Tiny_httpd_core)
(libraries
tiny_httpd unix
tiny_httpd.core unix
(select time_.ml from
(mtime mtime.clock.os -> time_.mtime.ml)
(-> time_.default.ml))))

21
src/prometheus/tiny_httpd_prometheus.ml
View file

@ -2,7 +2,7 @@
https://prometheus.io/docs/instrumenting/exposition_formats/#text-based-format
*)
open Common_
open Common_p_
let bpf = Printf.bprintf
@ -175,9 +175,7 @@ end
let global = Registry.create ()
module H = Tiny_httpd
let http_middleware (reg : Registry.t) : H.Middleware.t =
let http_middleware (reg : Registry.t) : Server.Middleware.t =
let c_req =
Counter.create reg "tiny_httpd_requests" ~descr:"number of HTTP requests"
in
@ -189,11 +187,11 @@ let http_middleware (reg : Registry.t) : H.Middleware.t =
~buckets:[ 0.001; 0.01; 0.1; 0.5; 1.; 5.; 10. ]
in
fun h : H.Middleware.handler ->
fun h : Server.Middleware.handler ->
fun req ~resp : unit ->
let start = Time_.now_us () in
Counter.incr c_req;
h req ~resp:(fun (response : H.Response.t) ->
h req ~resp:(fun (response : Response.t) ->
let code = response.code in
let elapsed_us = Time_.now_us () -. start in
@ -203,13 +201,14 @@ let http_middleware (reg : Registry.t) : H.Middleware.t =
if code < 200 || code >= 400 then Counter.incr c_err;
resp response)
let add_route_to_server (server : H.t) (reg : registry) : unit =
H.add_route_handler server H.Route.(exact "metrics" @/ return) @@ fun _req ->
let add_route_to_server (server : Server.t) (reg : registry) : unit =
Server.add_route_handler server Route.(exact "metrics" @/ return)
@@ fun _req ->
let str = Registry.emit_str reg in
H.Response.make_string @@ Ok str
Response.make_string @@ Ok str
let instrument_server (server : H.t) reg : unit =
H.add_middleware ~stage:(`Stage 1) server (http_middleware reg);
let instrument_server (server : Server.t) reg : unit =
Server.add_middleware ~stage:(`Stage 1) server (http_middleware reg);
add_route_to_server server reg
module GC_metrics = struct

6
src/prometheus/tiny_httpd_prometheus.mli
View file

@ -77,13 +77,13 @@ end
end
*)
val http_middleware : Registry.t -> Tiny_httpd.Middleware.t
val http_middleware : Registry.t -> Server.Middleware.t
(** Middleware to get basic metrics about HTTP requests *)
val add_route_to_server : Tiny_httpd.t -> Registry.t -> unit
val add_route_to_server : Server.t -> Registry.t -> unit
(** Add a "/metrics" route to the server *)
val instrument_server : Tiny_httpd.t -> Registry.t -> unit
val instrument_server : Server.t -> Registry.t -> unit
(** Add middleware and route *)
module GC_metrics : sig

70
src/Tiny_httpd_dir.ml → src/unix/dir.ml
View file

@ -1,7 +1,7 @@
module S = Tiny_httpd_server
module U = Tiny_httpd_util
module S = Server
module U = Util
module Html = Tiny_httpd_html
module Log = Tiny_httpd_log
module Log = Log
type dir_behavior = Index | Lists | Index_or_lists | Forbidden
type hidden = unit
@ -78,7 +78,7 @@ module type VFS = sig
val list_dir : string -> string array
val delete : string -> unit
val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
val read_file_content : string -> Tiny_httpd_stream.t
val read_file_content : string -> IO.Input.t
val file_size : string -> int option
val file_mtime : string -> float option
end
@ -99,7 +99,8 @@ let vfs_of_dir (top : string) : vfs =
| { st_kind = Unix.S_REG; _ } ->
let ic = Unix.(openfile fpath [ O_RDONLY ] 0) in
let closed = ref false in
Tiny_httpd_stream.of_fd_close_noerr ~closed ic
let buf = IO.Slice.create 4096 in
IO.Input.of_unix_fd ~buf ~close_noerr:true ~closed ic
| _ -> failwith (Printf.sprintf "not a regular file: %S" f)
let create f =
@ -216,51 +217,52 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
: unit =
let route () =
if prefix = "" then
S.Route.rest_of_path_urlencoded
Route.rest_of_path_urlencoded
else
S.Route.exact_path prefix S.Route.rest_of_path_urlencoded
Route.exact_path prefix Route.rest_of_path_urlencoded
in
if config.delete then
S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req ->
if contains_dot_dot path then
S.Response.fail_raise ~code:403 "invalid path in delete"
Response.fail_raise ~code:403 "invalid path in delete"
else
S.Response.make_string
Response.make_string
(try
VFS.delete path;
Ok "file deleted successfully"
with e -> Error (500, Printexc.to_string e)))
else
S.add_route_handler server ~meth:`DELETE (route ()) (fun _ _ ->
S.Response.make_raw ~code:405 "delete not allowed");
Response.make_raw ~code:405 "delete not allowed");
if config.upload then
S.add_route_handler_stream server ~meth:`PUT (route ())
~accept:(fun req ->
match S.Request.get_header_int req "Content-Length" with
match Request.get_header_int req "Content-Length" with
| Some n when n > config.max_upload_size ->
Error
(403, "max upload size is " ^ string_of_int config.max_upload_size)
| Some _ when contains_dot_dot req.S.Request.path ->
| Some _ when contains_dot_dot req.Request.path ->
Error (403, "invalid path (contains '..')")
| _ -> Ok ())
(fun path req ->
let write, close =
try VFS.create path
with e ->
S.Response.fail_raise ~code:403 "cannot upload to %S: %s" path
Response.fail_raise ~code:403 "cannot upload to %S: %s" path
(Printexc.to_string e)
in
let req =
S.Request.limit_body_size ~max_size:config.max_upload_size req
Request.limit_body_size ~bytes:(Bytes.create 4096)
~max_size:config.max_upload_size req
in
Tiny_httpd_stream.iter write req.S.Request.body;
IO.Input.iter write req.body;
close ();
Log.debug (fun k -> k "dir: done uploading file to %S" path);
S.Response.make_raw ~code:201 "upload successful")
Response.make_raw ~code:201 "upload successful")
else
S.add_route_handler server ~meth:`PUT (route ()) (fun _ _ ->
S.Response.make_raw ~code:405 "upload not allowed");
Response.make_raw ~code:405 "upload not allowed");
if config.download then
S.add_route_handler server ~meth:`GET (route ()) (fun path req ->
@ -268,19 +270,18 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
let mtime =
lazy
(match VFS.file_mtime path with
| None -> S.Response.fail_raise ~code:403 "Cannot access file"
| None -> Response.fail_raise ~code:403 "Cannot access file"
| Some t -> Printf.sprintf "mtime: %.4f" t)
in
if contains_dot_dot path then
S.Response.fail ~code:403 "Path is forbidden"
Response.fail ~code:403 "Path is forbidden"
else if not (VFS.contains path) then
S.Response.fail ~code:404 "File not found"
else if
S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
Response.fail ~code:404 "File not found"
else if Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
then (
Log.debug (fun k ->
k "dir: cached object %S (etag: %S)" path (Lazy.force mtime));
S.Response.make_raw ~code:304 ""
Response.make_raw ~code:304 ""
) else if VFS.is_directory path then (
Log.debug (fun k -> k "dir: list dir %S (topdir %S)" path VFS.descr);
let parent = Filename.(dirname path) in
@ -295,33 +296,36 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
(* redirect using path, not full path *)
let new_path = "/" // prefix // path // "index.html" in
Log.debug (fun k -> k "dir: redirect to `%s`" new_path);
S.Response.make_void ~code:301 ()
~headers:S.Headers.(empty |> set "location" new_path)
Response.make_void ~code:301 ()
~headers:Headers.(empty |> set "location" new_path)
| Lists | Index_or_lists ->
let body =
html_list_dir ~prefix vfs path ~parent |> Html.to_string_top
in
S.Response.make_string
Response.make_string
~headers:[ header_html; "ETag", Lazy.force mtime ]
(Ok body)
| Forbidden | Index ->
S.Response.make_raw ~code:405 "listing dir not allowed"
Response.make_raw ~code:405 "listing dir not allowed"
) else (
try
let mime_type =
if Filename.extension path = ".css" then
(* FIXME: handle .html specially *)
if Filename.extension path = ".html" then
[ "Content-Type", "text/html" ]
else if Filename.extension path = ".css" then
[ "Content-Type", "text/css" ]
else if Filename.extension path = ".js" then
[ "Content-Type", "text/javascript" ]
else if on_fs then (
(* call "file" util *)
let ty = Tiny_httpd_mime_.mime_of_path (top // path) in
let ty = Mime_.mime_of_path (top // path) in
[ "content-type", ty ]
) else
[]
in
let stream = VFS.read_file_content path in
S.Response.make_raw_stream
Response.make_raw_stream
~headers:(mime_type @ [ "Etag", Lazy.force mtime ])
~code:200 stream
with e ->
@ -330,11 +334,11 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
Log.error (fun k ->
k "dir.get failed: %s@.%s" msg
(Printexc.raw_backtrace_to_string bt));
S.Response.fail ~code:500 "error while reading file: %s" msg
Response.fail ~code:500 "error while reading file: %s" msg
))
else
S.add_route_handler server ~meth:`GET (route ()) (fun _ _ ->
S.Response.make_raw ~code:405 "download not allowed");
Response.make_raw ~code:405 "download not allowed");
()
let add_vfs ~config ~vfs ~prefix server : unit =
@ -437,7 +441,7 @@ module Embedded_fs = struct
let read_file_content p =
match find_ self p with
| Some (File { content; _ }) -> Tiny_httpd_stream.of_string content
| Some (File { content; _ }) -> IO.Input.of_string content
| _ -> failwith (Printf.sprintf "no such file: %S" p)
let list_dir p =

10
src/Tiny_httpd_dir.mli → src/unix/dir.mli
View file

@ -60,7 +60,7 @@ val config :
@since 0.12 *)
val add_dir_path :
config:config -> dir:string -> prefix:string -> Tiny_httpd_server.t -> unit
config:config -> dir:string -> prefix:string -> Server.t -> unit
(** [add_dirpath ~config ~dir ~prefix server] adds route handle to the
[server] to serve static files in [dir] when url starts with [prefix],
using the given configuration [config]. *)
@ -91,7 +91,7 @@ module type VFS = sig
val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
(** Create a file and obtain a pair [write, close] *)
val read_file_content : string -> Tiny_httpd_stream.t
val read_file_content : string -> IO.Input.t
(** Read content of a file *)
val file_size : string -> int option
@ -108,11 +108,7 @@ val vfs_of_dir : string -> (module VFS)
*)
val add_vfs :
config:config ->
vfs:(module VFS) ->
prefix:string ->
Tiny_httpd_server.t ->
unit
config:config -> vfs:(module VFS) -> prefix:string -> Server.t -> unit
(** Similar to {!add_dir_path} but using a virtual file system instead.
@since 0.12
*)

12
src/unix/dune Normal file
View file

@ -0,0 +1,12 @@
(library
(name tiny_httpd_unix)
(public_name tiny_httpd.unix)
(synopsis "Backend based on Unix and blocking IOs for Tiny_httpd")
(flags :standard -open Tiny_httpd_core)
(private_modules mime_)
(libraries tiny_httpd.core tiny_httpd.html unix
(select mime_.ml from
(magic-mime -> mime_.magic.ml)
( -> mime_.dummy.ml))
))

0
src/Tiny_httpd_mime_.dummy.ml → src/unix/mime_.dummy.ml
View file

0
src/Tiny_httpd_mime_.magic.ml → src/unix/mime_.magic.ml
View file

0
src/Tiny_httpd_mime_.mli → src/unix/mime_.mli
View file

25
src/unix/sem.ml Normal file
View file

@ -0,0 +1,25 @@
(** semaphore, for limiting concurrency. *)
type t = { mutable n: int; max: int; mutex: Mutex.t; cond: Condition.t }
let create n =
if n <= 0 then invalid_arg "Semaphore.create";
{ n; max = n; mutex = Mutex.create (); cond = Condition.create () }
let acquire m t =
Mutex.lock t.mutex;
while t.n < m do
Condition.wait t.cond t.mutex
done;
assert (t.n >= m);
t.n <- t.n - m;
Condition.broadcast t.cond;
Mutex.unlock t.mutex
let release m t =
Mutex.lock t.mutex;
t.n <- t.n + m;
Condition.broadcast t.cond;
Mutex.unlock t.mutex
let num_acquired t = t.max - t.n

155
src/unix/tiny_httpd_unix.ml Normal file
View file

@ -0,0 +1,155 @@
module Dir = Dir
module Sem = Sem
module Unix_tcp_server_ = struct
let get_addr_ sock =
match Unix.getsockname sock with
| Unix.ADDR_INET (addr, port) -> addr, port
| _ -> invalid_arg "httpd: address is not INET"
type t = {
addr: string;
port: int;
buf_pool: Buf.t Pool.t;
slice_pool: IO.Slice.t Pool.t;
max_connections: int;
sem_max_connections: Sem.t;
(** semaphore to restrict the number of active concurrent connections *)
mutable sock: Unix.file_descr option; (** Socket *)
new_thread: (unit -> unit) -> unit;
timeout: float;
masksigpipe: bool;
mutable running: bool; (* TODO: use an atomic? *)
}
let shutdown_silent_ fd =
try Unix.shutdown fd Unix.SHUTDOWN_ALL with _ -> ()
let close_silent_ fd = try Unix.close fd with _ -> ()
let to_tcp_server (self : t) : IO.TCP_server.builder =
{
IO.TCP_server.serve =
(fun ~after_init ~handle () : unit ->
if self.masksigpipe then
ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list);
let sock, should_bind =
match self.sock with
| Some s ->
( s,
false
(* Because we're getting a socket from the caller (e.g. systemd) *)
)
| None ->
( Unix.socket
(if Util.is_ipv6_str self.addr then
Unix.PF_INET6
else
Unix.PF_INET)
Unix.SOCK_STREAM 0,
true (* Because we're creating the socket ourselves *) )
in
Unix.clear_nonblock sock;
Unix.setsockopt_optint sock Unix.SO_LINGER None;
if should_bind then (
let inet_addr = Unix.inet_addr_of_string self.addr in
Unix.setsockopt sock Unix.SO_REUSEADDR true;
Unix.bind sock (Unix.ADDR_INET (inet_addr, self.port));
let n_listen = 2 * self.max_connections in
Unix.listen sock n_listen
);
self.sock <- Some sock;
let tcp_server =
{
IO.TCP_server.stop = (fun () -> self.running <- false);
running = (fun () -> self.running);
active_connections =
(fun () -> Sem.num_acquired self.sem_max_connections - 1);
endpoint =
(fun () ->
let addr, port = get_addr_ sock in
Unix.string_of_inet_addr addr, port);
}
in
after_init tcp_server;
(* how to handle a single client *)
let handle_client_unix_ (client_sock : Unix.file_descr)
(client_addr : Unix.sockaddr) : unit =
Log.debug (fun k ->
k "t[%d]: serving new client on %s"
(Thread.id @@ Thread.self ())
(Util.show_sockaddr client_addr));
if self.masksigpipe then
ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list);
Unix.set_nonblock client_sock;
Unix.setsockopt client_sock Unix.TCP_NODELAY true;
Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout);
Unix.(setsockopt_float client_sock SO_SNDTIMEO self.timeout);
Pool.with_resource self.slice_pool @@ fun ic_buf ->
Pool.with_resource self.slice_pool @@ fun oc_buf ->
let closed = ref false in
let oc =
new IO.Output.of_unix_fd
~close_noerr:true ~closed ~buf:oc_buf client_sock
in
let ic =
IO.Input.of_unix_fd ~close_noerr:true ~closed ~buf:ic_buf
client_sock
in
handle.handle ~client_addr ic oc
in
Unix.set_nonblock sock;
while self.running do
match Unix.accept sock with
| client_sock, client_addr ->
(* limit concurrency *)
Sem.acquire 1 self.sem_max_connections;
(* Block INT/HUP while cloning to avoid children handling them.
When thread gets them, our Unix.accept raises neatly. *)
ignore Unix.(sigprocmask SIG_BLOCK Sys.[ sigint; sighup ]);
self.new_thread (fun () ->
try
handle_client_unix_ client_sock client_addr;
Log.debug (fun k ->
k "t[%d]: done with client on %s, exiting"
(Thread.id @@ Thread.self ())
@@ Util.show_sockaddr client_addr);
shutdown_silent_ client_sock;
close_silent_ client_sock;
Sem.release 1 self.sem_max_connections
with e ->
let bt = Printexc.get_raw_backtrace () in
shutdown_silent_ client_sock;
close_silent_ client_sock;
Sem.release 1 self.sem_max_connections;
Log.error (fun k ->
k
"@[<v>Handler: uncaught exception for client %s:@ \
%s@ %s@]"
(Util.show_sockaddr client_addr)
(Printexc.to_string e)
(Printexc.raw_backtrace_to_string bt)));
ignore Unix.(sigprocmask SIG_UNBLOCK Sys.[ sigint; sighup ])
| exception Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _)
->
(* wait for the socket to be ready, and re-enter the loop *)
ignore (Unix.select [ sock ] [] [ sock ] 1.0 : _ * _ * _)
| exception e ->
Log.error (fun k ->
k "Unix.accept raised an exception: %s" (Printexc.to_string e));
Thread.delay 0.01
done;
(* Wait for all threads to be done: this only works if all threads are done. *)
Unix.close sock;
Sem.acquire self.sem_max_connections.max self.sem_max_connections;
());
}
end

0
src/ws/common_.ml → src/ws/common_ws_.ml
View file

5
src/ws/dune
View file

@ -3,9 +3,10 @@
(name tiny_httpd_ws)
(public_name tiny_httpd.ws)
(synopsis "Websockets for tiny_httpd")
(private_modules common_ utils_)
(private_modules common_ws_ utils_)
(flags :standard -open Tiny_httpd_core)
(foreign_stubs
(language c)
(names tiny_httpd_ws_stubs)
(flags :standard -std=c99 -fPIC -O2))
(libraries tiny_httpd threads))
(libraries tiny_httpd.core threads))

41
src/ws/tiny_httpd_ws.ml
View file

@ -1,7 +1,4 @@
open Common_
open Tiny_httpd_server
module Log = Tiny_httpd_log
module IO = Tiny_httpd_io
open Common_ws_
type handler = Unix.sockaddr -> IO.Input.t -> IO.Output.t -> unit
@ -382,21 +379,23 @@ let upgrade ic oc : _ * _ =
let writer = Writer.create ~oc () in
let reader = Reader.create ~ic ~writer () in
let ws_ic : IO.Input.t =
{
input = (fun buf i len -> Reader.read reader buf i len);
close = (fun () -> Reader.close reader);
}
object
inherit IO.Input.t_from_refill ~bytes:(Bytes.create 4_096) ()
method private refill (slice : IO.Slice.t) =
slice.off <- 0;
slice.len <- Reader.read reader slice.bytes 0 (Bytes.length slice.bytes)
method close () = Reader.close reader
end
in
let ws_oc : IO.Output.t =
{
flush =
(fun () ->
Writer.flush writer;
IO.Output.flush oc);
output_char = Writer.output_char writer;
output = Writer.output writer;
close = (fun () -> Writer.close writer);
}
object
method close () = Writer.close writer
method flush () = Writer.flush writer
method output bs i len = Writer.output writer bs i len
method output_char c = Writer.output_char writer c
end
in
ws_ic, ws_oc
@ -404,7 +403,7 @@ let upgrade ic oc : _ * _ =
module Make_upgrade_handler (X : sig
val accept_ws_protocol : string -> bool
val handler : handler
end) : UPGRADE_HANDLER = struct
end) : Server.UPGRADE_HANDLER = struct
type handshake_state = unit
let name = "websocket"
@ -454,10 +453,10 @@ end) : UPGRADE_HANDLER = struct
end
let add_route_handler ?accept ?(accept_ws_protocol = fun _ -> true)
(server : Tiny_httpd_server.t) route (f : handler) : unit =
(server : Server.t) route (f : handler) : unit =
let module M = Make_upgrade_handler (struct
let handler = f
let accept_ws_protocol = accept_ws_protocol
end) in
let up : upgrade_handler = (module M) in
Tiny_httpd_server.add_upgrade_handler ?accept server route up
let up : Server.upgrade_handler = (module M) in
Server.add_upgrade_handler ?accept server route up

7
src/ws/tiny_httpd_ws.mli
View file

@ -4,9 +4,6 @@
for a websocket server. It has no additional dependencies.
*)
open Tiny_httpd_server
module IO = Tiny_httpd_io
type handler = Unix.sockaddr -> IO.Input.t -> IO.Output.t -> unit
(** Websocket handler *)
@ -16,8 +13,8 @@ val upgrade : IO.Input.t -> IO.Output.t -> IO.Input.t * IO.Output.t
val add_route_handler :
?accept:(unit Request.t -> (unit, int * string) result) ->
?accept_ws_protocol:(string -> bool) ->
Tiny_httpd_server.t ->
(upgrade_handler, upgrade_handler) Route.t ->
Server.t ->
(Server.upgrade_handler, Server.upgrade_handler) Route.t ->
handler ->
unit
(** Add a route handler for a websocket endpoint.

2
tests/unit/dune
View file

@ -2,4 +2,4 @@
(tests
(names t_util t_buf t_server)
(package tiny_httpd)
(libraries tiny_httpd qcheck-core qcheck-core.runner test_util))
(libraries tiny_httpd.core qcheck-core qcheck-core.runner test_util))

2
tests/unit/t_buf.ml
View file

@ -1,5 +1,5 @@
open Test_util
open Tiny_httpd_buf
open Tiny_httpd_core.Buf
let spf = Printf.sprintf

22
tests/unit/t_server.ml
View file

@ -1,5 +1,5 @@
open Test_util
open Tiny_httpd_server
open Tiny_httpd_core
let () =
let q =
@ -9,16 +9,20 @@ let () =
\r\n\
salutationsSOMEJUNK"
in
let str = Tiny_httpd.Byte_stream.of_string q in
let str = IO.Input.of_string q in
let client_addr = Unix.(ADDR_INET (inet_addr_loopback, 1024)) in
let r = Request.Internal_.parse_req_start ~client_addr ~get_time_s:(fun _ -> 0.) str in
let r =
Request.Private_.parse_req_start_exn ~client_addr ~buf:(Buf.create ())
~get_time_s:(fun _ -> 0.)
str
in
match r with
| None -> failwith "should parse"
| Some req ->
assert_eq (Some "coucou") (Headers.get "Host" req.Request.headers);
assert_eq (Some "coucou") (Headers.get "host" req.Request.headers);
assert_eq (Some "11") (Headers.get "content-length" req.Request.headers);
assert_eq "hello" req.Request.path;
let req = Request.Internal_.parse_body req str |> Request.read_body_full in
assert_eq ~to_string:(fun s -> s) "salutations" req.Request.body;
assert_eq (Some "coucou") (Headers.get "Host" req.headers);
assert_eq (Some "coucou") (Headers.get "host" req.headers);
assert_eq (Some "11") (Headers.get "content-length" req.headers);
assert_eq "hello" req.path;
let req = Request.Private_.parse_body req str |> Request.read_body_full in
assert_eq ~to_string:(fun s -> s) "salutations" req.body;
()

35
tests/unit/t_util.ml
View file

@ -1,33 +1,36 @@
open Test_util
open Tiny_httpd_util
open Tiny_httpd_core
module U = Util
let () = assert_eq "hello%20world" (percent_encode "hello world")
let () = assert_eq "%23%25^%24%40^%40" (percent_encode "#%^$@^@")
let () = assert_eq "hello%20world" (U.percent_encode "hello world")
let () = assert_eq "%23%25^%24%40^%40" (U.percent_encode "#%^$@^@")
let () =
assert_eq "a%20ohm%2B5235%25%26%40%23%20---%20_"
(percent_encode "a ohm+5235%&@# --- _")
(U.percent_encode "a ohm+5235%&@# --- _")
let () = assert_eq (Some "?") (percent_decode @@ percent_encode "?")
let () = assert_eq (Some "?") (U.percent_decode @@ U.percent_encode "?")
let () =
add_qcheck
@@ QCheck.Test.make ~count:1_000 ~long_factor:20 Q.string (fun s ->
String.iter (fun c -> Q.assume @@ is_ascii_char c) s;
match percent_decode (percent_encode s) with
match U.percent_decode (U.percent_encode s) with
| Some s' -> s = s'
| None -> Q.Test.fail_report "invalid percent encoding")
let () = assert_eq [ "a"; "b" ] (split_on_slash "/a/b")
let () = assert_eq [ "coucou"; "lol" ] (split_on_slash "/coucou/lol")
let () = assert_eq [ "a"; "b"; "c" ] (split_on_slash "/a/b//c/")
let () = assert_eq [ "a"; "b" ] (split_on_slash "//a/b/")
let () = assert_eq [ "a" ] (split_on_slash "/a//")
let () = assert_eq [] (split_on_slash "/")
let () = assert_eq [] (split_on_slash "//")
let () = assert_eq [ "a"; "b" ] (U.split_on_slash "/a/b")
let () = assert_eq [ "coucou"; "lol" ] (U.split_on_slash "/coucou/lol")
let () = assert_eq [ "a"; "b"; "c" ] (U.split_on_slash "/a/b//c/")
let () = assert_eq [ "a"; "b" ] (U.split_on_slash "//a/b/")
let () = assert_eq [ "a" ] (U.split_on_slash "/a//")
let () = assert_eq [] (U.split_on_slash "/")
let () = assert_eq [] (U.split_on_slash "//")
let () =
assert_eq ~cmp:eq_sorted (Ok [ "a", "b"; "c", "d" ]) (parse_query "a=b&c=d")
assert_eq ~cmp:eq_sorted (Ok [ "a", "b"; "c", "d" ]) (U.parse_query "a=b&c=d")
let () = assert_eq (Ok [ "foo", "bar" ]) (U.parse_query "yolo#foo=bar")
let () =
add_qcheck
@ -43,9 +46,9 @@ let () =
let s =
String.concat "&"
(List.map
(fun (x, y) -> percent_encode x ^ "=" ^ percent_encode y)
(fun (x, y) -> U.percent_encode x ^ "=" ^ U.percent_encode y)
l)
in
eq_sorted (Ok l) (parse_query s))
eq_sorted (Ok l) (U.parse_query s))
let () = run_qcheck_and_exit ()

2
tests/unit/util/dune
View file

@ -2,4 +2,4 @@
(library
(name test_util)
(modules test_util)
(libraries qcheck-core qcheck-core.runner))
(libraries logs qcheck-core qcheck-core.runner))

4
tests/unit/util/test_util.ml
View file

@ -29,3 +29,7 @@ let add_qcheck f = qchecks := f :: !qchecks
let run_qcheck_and_exit () : 'a =
exit @@ QCheck_base_runner.run_tests ~colors:false !qchecks
let setup_logs_debug () =
Logs.set_reporter @@ Logs.format_reporter ();
Logs.set_level ~all:true @@ Some Logs.Debug

2
tiny_httpd.opam
View file

@ -15,6 +15,8 @@ depends: [
"seq"
"base-threads"
"result"
"hmap"
"iostream" {>= "0.2"}
"ocaml" {>= "4.08"}
"odoc" {with-doc}
"logs" {with-test}

1
tiny_httpd_camlzip.opam
View file

@ -11,6 +11,7 @@ depends: [
"dune" {>= "2.9"}
"tiny_httpd" {= version}
"camlzip" {>= "1.06"}
"iostream-camlzip"
"logs" {with-test}
"odoc" {with-doc}
]

1
vendor/iostream vendored Submodule

@ -0,0 +1 @@
Subproject commit 668a7c22c09d21293c9ce3fd8bc66b3080c525d2