simon/tiny_httpd
1
0
Fork 0
mirror of https://github.com/c-cube/tiny_httpd.git synced 2026-01-26 11:24:50 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

refactor the rest

Browse source
This commit is contained in:
Simon Cruanes 2024-02-26 13:55:20 -05:00
parent 8e2cf23e27
commit 04be73ee00
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
45 changed files with 322 additions and 4097 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

2
dune-project
View file

@ -21,6 +21,8 @@
seq seq
base-threads base-threads
result result
hmap
(iostream (>= 0.2))
(ocaml (>= 4.08)) (ocaml (>= 4.08))
(odoc :with-doc) (odoc :with-doc)
(logs :with-test) (logs :with-test)

66
src/Tiny_httpd.ml
View file

@ -1,9 +1,59 @@
module Buf = Tiny_httpd_buf module Buf = Buf
module Byte_stream = Tiny_httpd_stream include Server
include Tiny_httpd_server module Util = Util
module Util = Tiny_httpd_util module Dir = Tiny_httpd_unix.Dir
module Dir = Tiny_httpd_dir
module Html = Tiny_httpd_html module Html = Tiny_httpd_html
module IO = Tiny_httpd_io module IO = Tiny_httpd_core.IO
module Pool = Tiny_httpd_pool module Pool = Tiny_httpd_core.Pool
module Log = Tiny_httpd_log module Log = Tiny_httpd_core.Log
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 ()

18
src/Tiny_httpd.mli
View file

@ -79,38 +79,34 @@ echo:
processing streams and parsing requests. processing streams and parsing requests.
*) *)
module Buf = Tiny_httpd_buf module Buf = Buf
(** {2 Generic byte streams} *)
module Byte_stream = Tiny_httpd_stream
(** {2 IO Abstraction} *) (** {2 IO Abstraction} *)
module IO = Tiny_httpd_io module IO = Tiny_httpd_core.IO
(** {2 Logging *) (** {2 Logging *)
module Log = Tiny_httpd_log module Log = Tiny_httpd_core.Log
(** {2 Main Server Type} *) (** {2 Main Server Type} *)
(** @inline *) (** @inline *)
include module type of struct include module type of struct
include Tiny_httpd_server include Tiny_httpd_core.Server
end end
(** {2 Utils} *) (** {2 Utils} *)
module Util = Tiny_httpd_util module Util = Tiny_httpd_core.Util
(** {2 Resource pool} *) (** {2 Resource pool} *)
module Pool = Tiny_httpd_pool module Pool = Tiny_httpd_core.Pool
(** {2 Static directory serving} *) (** {2 Static directory serving} *)
module Dir = Tiny_httpd_dir module Dir = Tiny_httpd_unix.Dir
module Html = Tiny_httpd_html module Html = Tiny_httpd_html
(** Alias to {!Tiny_httpd_html} (** Alias to {!Tiny_httpd_html}

55
src/Tiny_httpd_buf.ml
View file

@ -1,55 +0,0 @@
type t = { mutable bytes: bytes; mutable i: int; original: bytes }
let create ?(size = 4_096) () : t =
let bytes = Bytes.make size ' ' in
{ bytes; i = 0; original = bytes }
let[@inline] size self = self.i
let[@inline] bytes_slice self = self.bytes
let clear self : unit =
if
Bytes.length self.bytes > 500 * 1_024
&& Bytes.length self.bytes > Bytes.length self.original
then
(* free big buffer *)
self.bytes <- self.original;
self.i <- 0
let clear_and_zero self =
clear self;
Bytes.fill self.bytes 0 (Bytes.length self.bytes) '\x00'
let resize self new_size : unit =
let new_buf = Bytes.make new_size ' ' in
Bytes.blit self.bytes 0 new_buf 0 self.i;
self.bytes <- new_buf
let add_char self c : unit =
if self.i + 1 >= Bytes.length self.bytes then
resize self (self.i + (self.i / 2) + 10);
Bytes.set self.bytes self.i c;
self.i <- 1 + self.i
let add_bytes (self : t) s i len : unit =
if self.i + len >= Bytes.length self.bytes then
resize self (self.i + (self.i / 2) + len + 10);
Bytes.blit s i self.bytes self.i len;
self.i <- self.i + len
let[@inline] add_string self str : unit =
add_bytes self (Bytes.unsafe_of_string str) 0 (String.length str)
let add_buffer (self : t) (buf : Buffer.t) : unit =
let len = Buffer.length buf in
if self.i + len >= Bytes.length self.bytes then
resize self (self.i + (self.i / 2) + len + 10);
Buffer.blit buf 0 self.bytes self.i len;
self.i <- self.i + len
let contents (self : t) : string = Bytes.sub_string self.bytes 0 self.i
let contents_and_clear (self : t) : string =
let x = contents self in
clear self;
x

42
src/Tiny_httpd_buf.mli
View file

@ -1,42 +0,0 @@
(** Simple buffer.
These buffers are used to avoid allocating too many byte arrays when
processing streams and parsing requests.
@since 0.12
*)
type t
val size : t -> int
val clear : t -> unit
val create : ?size:int -> unit -> t
val contents : t -> string
val clear_and_zero : t -> unit
(** Clear the buffer and zero out its storage.
@since 0.15 *)
val bytes_slice : t -> bytes
(** Access underlying slice of bytes.
@since 0.5 *)
val contents_and_clear : t -> string
(** Get contents of the buffer and clear it.
@since 0.5 *)
val add_char : t -> char -> unit
(** Add a single char.
@since 0.14 *)
val add_bytes : t -> bytes -> int -> int -> unit
(** Append given bytes slice to the buffer.
@since 0.5 *)
val add_string : t -> string -> unit
(** Add string.
@since 0.14 *)
val add_buffer : t -> Buffer.t -> unit
(** Append bytes from buffer.
@since 0.14 *)

65
src/Tiny_httpd_html.ml
View file

@ -1,65 +0,0 @@
(** HTML combinators.
This module provides combinators to produce html. It doesn't enforce
the well-formedness of the html, unlike Tyxml, but it's simple and should
be reasonably efficient.
@since 0.12
*)
module IO = Tiny_httpd_io
include Tiny_httpd_html_
(** @inline *)
(** Write an HTML element to this output.
@param top if true, add DOCTYPE at the beginning. The top element should then
be a "html" tag.
@since 0.14
*)
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;
Out.add_format_nl out;
Out.flush out
(** Convert a HTML element to a string.
@param top if true, add DOCTYPE at the beginning. The top element should then
be a "html" tag. *)
let to_string ?top (self : elt) : string =
let buf = Buffer.create 64 in
let out = IO.Output.of_buffer buf in
to_output ?top self out;
Buffer.contents buf
(** Convert a list of HTML elements to a string.
This is designed for fragments of HTML that are to be injected inside
a bigger context, as it's invalid to have multiple elements at the toplevel
of a HTML document. *)
let to_string_l (l : elt list) =
let buf = Buffer.create 64 in
let out = Out.create_of_buffer buf in
List.iter
(fun f ->
f out;
Out.add_format_nl out)
l;
Buffer.contents buf
let to_string_top = to_string ~top:true
(** Write a toplevel element to an output channel.
@since 0.14 *)
let to_out_channel_top = to_output ~top:true
(** Produce a streaming writer from this HTML element.
@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
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

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

7
src/Tiny_httpd_log.default.ml
View file

@ -1,7 +0,0 @@
(* default: no logging *)
let info _ = ()
let debug _ = ()
let error _ = ()
let setup ~debug:_ () = ()
let dummy = true

22
src/Tiny_httpd_log.logs.ml
View file

@ -1,22 +0,0 @@
(* Use Logs *)
module Log = (val Logs.(src_log @@ Src.create "tiny_httpd"))
let info k = Log.info (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
let debug k = Log.debug (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
let error k = Log.err (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
let setup ~debug () =
let mutex = Mutex.create () in
Logs.set_reporter_mutex
~lock:(fun () -> Mutex.lock mutex)
~unlock:(fun () -> Mutex.unlock mutex);
Logs.set_reporter @@ Logs.format_reporter ();
Logs.set_level ~all:true
(Some
(if debug then
Logs.Debug
else
Logs.Info))
let dummy = false

12
src/Tiny_httpd_log.mli
View file

@ -1,12 +0,0 @@
(** Logging for tiny_httpd *)
val info : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
val debug : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
val error : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
val setup : debug:bool -> unit -> unit
(** Setup and enable logging. This should only ever be used in executables,
not libraries.
@param debug if true, set logging to debug (otherwise info) *)
val dummy : bool

1
src/Tiny_httpd_mime_.dummy.ml
View file

@ -1 +0,0 @@
let mime_of_path _ = "application/octet-stream"

1
src/Tiny_httpd_mime_.magic.ml
View file

@ -1 +0,0 @@
let mime_of_path s = Magic_mime.lookup s

2
src/Tiny_httpd_mime_.mli
View file

@ -1,2 +0,0 @@
val mime_of_path : string -> string

77
src/Tiny_httpd_parse_.ml
View file

@ -1,77 +0,0 @@
(** Basic parser for lines *)
type 'a t = string -> int ref -> 'a
open struct
let spf = Printf.sprintf
end
let[@inline] eof s off = !off = String.length s
let[@inline] skip_space : unit t =
fun s off ->
while !off < String.length s && String.unsafe_get s !off = ' ' do
incr off
done
let pos_int : int t =
fun s off : int ->
skip_space s off;
let n = ref 0 in
let continue = ref true in
while !off < String.length s && !continue do
match String.unsafe_get s !off with
| '0' .. '9' as c -> n := (!n * 10) + Char.code c - Char.code '0'
| ' ' | '\t' | '\n' -> continue := false
| c -> failwith @@ spf "expected int, got %C" c
done;
!n
let pos_hex : int t =
fun s off : int ->
skip_space s off;
let n = ref 0 in
let continue = ref true in
while !off < String.length s && !continue do
match String.unsafe_get s !off with
| 'a' .. 'f' as c ->
incr off;
n := (!n * 16) + Char.code c - Char.code 'a' + 10
| 'A' .. 'F' as c ->
incr off;
n := (!n * 16) + Char.code c - Char.code 'A' + 10
| '0' .. '9' as c ->
incr off;
n := (!n * 16) + Char.code c - Char.code '0'
| ' ' | '\r' -> continue := false
| c -> failwith @@ spf "expected int, got %C" c
done;
!n
(** Parse a word without spaces *)
let word : string t =
fun s off ->
skip_space s off;
let start = !off in
let continue = ref true in
while !off < String.length s && !continue do
match String.unsafe_get s !off with
| ' ' | '\r' -> continue := false
| _ -> incr off
done;
if !off = start then failwith "expected word";
String.sub s start (!off - start)
let exact str : unit t =
fun s off ->
skip_space s off;
let len = String.length str in
if !off + len > String.length s then
failwith @@ spf "unexpected EOF, expected %S" str;
for i = 0 to len - 1 do
let expected = String.unsafe_get str i in
let c = String.unsafe_get s (!off + i) in
if c <> expected then
failwith @@ spf "expected %S, got %C at position %d" str c i
done;
off := !off + len

51
src/Tiny_httpd_pool.ml
View file

@ -1,51 +0,0 @@
module A = Tiny_httpd_atomic_
type 'a list_ = Nil | Cons of int * 'a * 'a list_
type 'a t = {
mk_item: unit -> 'a;
clear: 'a -> unit;
max_size: int; (** Max number of items *)
items: 'a list_ A.t;
}
let create ?(clear = ignore) ~mk_item ?(max_size = 512) () : _ t =
{ mk_item; clear; max_size; items = A.make Nil }
let rec acquire_ self =
match A.get self.items with
| Nil -> self.mk_item ()
| Cons (_, x, tl) as l ->
if A.compare_and_set self.items l tl then
x
else
acquire_ self
let[@inline] size_ = function
| Cons (sz, _, _) -> sz
| Nil -> 0
let release_ self x : unit =
let rec loop () =
match A.get self.items with
| Cons (sz, _, _) when sz >= self.max_size ->
(* forget the item *)
()
| l ->
if not (A.compare_and_set self.items l (Cons (size_ l + 1, x, l))) then
loop ()
in
self.clear x;
loop ()
let with_resource (self : _ t) f =
let x = acquire_ self in
try
let res = f x in
release_ self x;
res
with e ->
let bt = Printexc.get_raw_backtrace () in
release_ self x;
Printexc.raise_with_backtrace e bt

25
src/Tiny_httpd_pool.mli
View file

@ -1,25 +0,0 @@
(** Resource pool.
This pool is used for buffers. It can be used for other resources
but do note that it assumes resources are still reasonably
cheap to produce and discard, and will never block waiting for
a resource — it's not a good pool for DB connections.
@since 0.14. *)
type 'a t
(** Pool of values of type ['a] *)
val create :
?clear:('a -> unit) -> mk_item:(unit -> 'a) -> ?max_size:int -> unit -> 'a t
(** Create a new pool.
@param mk_item produce a new item in case the pool is empty
@param max_size maximum number of item in the pool before we start
dropping resources on the floor. This controls resource consumption.
@param clear a function called on items before recycling them.
*)
val with_resource : 'a t -> ('a -> 'b) -> 'b
(** [with_resource pool f] runs [f x] with [x] a resource;
when [f] fails or returns, [x] is returned to the pool for
future reuse. *)

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

322
src/Tiny_httpd_stream.ml
View file

@ -1,322 +0,0 @@
module Buf = Tiny_httpd_buf
module IO = Tiny_httpd_io
let spf = Printf.sprintf
type hidden = unit
type t = {
mutable bs: bytes;
mutable off: int;
mutable len: int;
fill_buf: unit -> unit;
consume: int -> unit;
close: unit -> unit;
_rest: hidden;
}
let[@inline] close self = self.close ()
let empty =
{
bs = Bytes.empty;
off = 0;
len = 0;
fill_buf = ignore;
consume = ignore;
close = ignore;
_rest = ();
}
let make ?(bs = Bytes.create @@ (16 * 1024)) ?(close = ignore) ~consume ~fill ()
: t =
let rec self =
{
bs;
off = 0;
len = 0;
close = (fun () -> close self);
fill_buf = (fun () -> if self.len = 0 then fill self);
consume =
(fun n ->
assert (n <= self.len);
consume self n);
_rest = ();
}
in
self
let of_input ?(buf_size = 16 * 1024) (ic : IO.Input.t) : t =
make ~bs:(Bytes.create buf_size)
~close:(fun _ -> IO.Input.close ic)
~consume:(fun self n ->
assert (self.len >= n);
self.off <- self.off + n;
self.len <- self.len - n)
~fill:(fun self ->
if self.len = 0 then (
self.off <- 0;
self.len <- IO.Input.input ic self.bs 0 (Bytes.length self.bs)
))
()
let of_chan_ ?buf_size ic ~close_noerr : t =
let inc = IO.Input.of_in_channel ~close_noerr ic in
of_input ?buf_size inc
let of_chan ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:false
let of_chan_close_noerr ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:true
let of_fd_ ?buf_size ~close_noerr ~closed ic : t =
let inc = IO.Input.of_unix_fd ~close_noerr ~closed ic in
of_input ?buf_size inc
let of_fd ?buf_size ~closed fd : t =
of_fd_ ?buf_size ~closed ~close_noerr:false fd
let of_fd_close_noerr ?buf_size ~closed fd : t =
of_fd_ ?buf_size ~closed ~close_noerr:true fd
let iter f (self : t) : unit =
let continue = ref true in
while !continue do
self.fill_buf ();
if self.len = 0 then (
continue := false;
self.close ()
) else (
f self.bs self.off self.len;
self.consume self.len
)
done
let to_chan (oc : out_channel) (self : t) = iter (output oc) self
let to_chan' (oc : IO.Output.t) (self : t) = iter (IO.Output.output oc) self
let to_writer (self : t) : Tiny_httpd_io.Writer.t =
{ write = (fun oc -> to_chan' oc self) }
let of_bytes ?(i = 0) ?len (bs : bytes) : t =
(* invariant: !i+!len is constant *)
let len =
match len with
| Some n ->
if n > Bytes.length bs - i then invalid_arg "Byte_stream.of_bytes";
n
| None -> Bytes.length bs - i
in
let self =
make ~bs ~fill:ignore
~close:(fun self -> self.len <- 0)
~consume:(fun self n ->
assert (n >= 0 && n <= self.len);
self.off <- n + self.off;
self.len <- self.len - n)
()
in
self.off <- i;
self.len <- len;
self
let of_string s : t = of_bytes (Bytes.unsafe_of_string s)
let with_file ?buf_size file f =
let ic = Unix.(openfile file [ O_RDONLY ] 0) in
try
let x = f (of_fd ?buf_size ~closed:(ref false) ic) in
Unix.close ic;
x
with e ->
Unix.close ic;
raise e
let read_all ?(buf = Buf.create ()) (self : t) : string =
let continue = ref true in
while !continue do
self.fill_buf ();
if self.len = 0 then
continue := false
else (
assert (self.len > 0);
Buf.add_bytes buf self.bs self.off self.len;
self.consume self.len
)
done;
Buf.contents_and_clear buf
(* put [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
self.fill_buf ();
let n_read = min self.len (n - !offset) in
Bytes.blit self.bs self.off bytes !offset n_read;
offset := !offset + n_read;
self.consume 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
self.fill_buf ();
if self.len = 0 then (
continue := false;
if Buf.size buf = 0 then raise End_of_file
);
let j = ref self.off in
while !j < self.off + self.len && Bytes.get self.bs !j <> '\n' do
incr j
done;
if !j - self.off < self.len then (
assert (Bytes.get self.bs !j = '\n');
(* line without '\n' *)
Buf.add_bytes buf self.bs self.off (!j - self.off);
(* consume line + '\n' *)
self.consume (!j - self.off + 1);
continue := false
) else (
Buf.add_bytes buf self.bs self.off self.len;
self.consume self.len
)
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 =
if size = 0 then
empty
else (
let size = ref size in
make ~bs:Bytes.empty
~fill:(fun res ->
(* must not block on [arg] if we're done *)
if !size = 0 then (
res.bs <- Bytes.empty;
res.off <- 0;
res.len <- 0
) else (
arg.fill_buf ();
res.bs <- arg.bs;
res.off <- arg.off;
let len = min arg.len !size in
if len = 0 && !size > 0 then too_short !size;
res.len <- len
))
~close:(fun _res ->
(* close underlying stream if [close_rec] *)
if close_rec then arg.close ();
size := 0)
~consume:(fun res n ->
let n = min n !size in
size := !size - n;
arg.consume n;
res.off <- res.off + n;
res.len <- res.len - n)
()
)
let read_line ?(buf = Buf.create ()) self : string =
read_line_into self ~buf;
Buf.contents buf
let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
let first = ref true in
let read_next_chunk_len () : int =
if !first then
first := false
else (
let line = read_line ~buf bs in
if String.trim line <> "" then raise (fail "expected crlf between chunks")
);
let line = read_line ~buf bs in
(* parse chunk length, ignore extensions *)
let chunk_size =
if String.trim line = "" then
0
else (
try
let off = ref 0 in
let n = Tiny_httpd_parse_.pos_hex line off in
n
with _ ->
raise (fail (spf "cannot read chunk size from line %S" line))
)
in
chunk_size
in
let refill = ref true in
let chunk_size = ref 0 in
make
~bs:(Bytes.create (16 * 4096))
~fill:(fun self ->
(* do we need to refill? *)
if self.len = 0 then (
if !chunk_size = 0 && !refill then chunk_size := read_next_chunk_len ();
self.off <- 0;
self.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 self.bs) in
read_exactly_
~too_short:(fun () -> raise (fail "chunk is too short"))
bs self.bs to_read;
self.len <- to_read;
chunk_size := !chunk_size - to_read
) else
refill := false (* stream is finished *)
))
~consume:(fun self n ->
self.off <- self.off + n;
self.len <- self.len - n)
~close:(fun self ->
(* close this overlay, do not close underlying stream *)
self.len <- 0;
refill := false)
()
let output_chunked' ?buf (oc : IO.Output.t) (self : t) : unit =
let oc' = IO.Output.chunk_encoding ?buf oc ~close_rec:false in
match to_chan' oc' self with
| () -> IO.Output.close oc'
| exception e ->
let bt = Printexc.get_raw_backtrace () in
IO.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 (IO.Output.of_out_channel oc) self

159
src/Tiny_httpd_stream.mli
View file

@ -1,159 +0,0 @@
(** Byte streams.
Streams are used to represent a series of bytes that can arrive progressively.
For example, an uploaded file will be sent as a series of chunks.
These used to live in {!Tiny_httpd} but are now in their own module.
@since 0.12 *)
type hidden
(** Type used to make {!t} unbuildable via a record literal. Use {!make} instead. *)
type t = {
mutable bs: bytes; (** The bytes *)
mutable off: int; (** Beginning of valid slice in {!bs} *)
mutable len: int;
(** Length of valid slice in {!bs}. If [len = 0] after
a call to {!fill}, then the stream is finished. *)
fill_buf: unit -> unit;
(** See the current slice of the internal buffer as [bytes, i, len],
where the slice is [bytes[i] .. [bytes[i+len-1]]].
Can block to refill the buffer if there is currently no content.
If [len=0] then there is no more data. *)
consume: int -> unit;
(** Consume [n] bytes from the buffer.
This should only be called with [n <= len]. *)
close: unit -> unit; (** Close the stream. *)
_rest: hidden; (** Use {!make} to build a stream. *)
}
(** A buffered stream, with a view into the current buffer (or refill if empty),
and a function to consume [n] bytes.
The point of this type is that it gives the caller access to its internal buffer
([bs], with the slice [off,len]). This is convenient for things like line
reading where one needs to peek ahead.
Some core invariant for this type of stream are:
- [off,len] delimits a valid slice in [bs] (indices: [off, off+1, … off+len-1])
- if [fill_buf()] was just called, then either [len=0] which indicates the end
of stream; or [len>0] and the slice contains some data.
To actually move forward in the stream, you can call [consume n]
to consume [n] bytes (where [n <= len]). If [len] gets to [0], calling
[fill_buf()] is required, so it can try to obtain a new slice.
To emulate a classic OCaml reader with a [read: bytes -> int -> int -> int] function,
the simplest is:
{[
let read (self:t) buf offset max_len : int =
self.fill_buf();
let len = min max_len self.len in
if len > 0 then (
Bytes.blit self.bs self.off buf offset len;
self.consume len;
);
len
]}
*)
val close : t -> unit
(** Close stream *)
val empty : t
(** Stream with 0 bytes inside *)
val of_input : ?buf_size:int -> Tiny_httpd_io.Input.t -> t
(** Make a buffered stream from the given channel.
@since 0.14 *)
val of_chan : ?buf_size:int -> in_channel -> t
(** Make a buffered stream from the given channel. *)
val of_chan_close_noerr : ?buf_size:int -> in_channel -> t
(** Same as {!of_chan} but the [close] method will never fail. *)
val of_fd : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t
(** Make a buffered stream from the given file descriptor. *)
val of_fd_close_noerr : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t
(** Same as {!of_fd} but the [close] method will never fail. *)
val of_bytes : ?i:int -> ?len:int -> bytes -> t
(** A stream that just returns the slice of bytes starting from [i]
and of length [len]. *)
val of_string : string -> t
val iter : (bytes -> int -> int -> unit) -> t -> unit
(** Iterate on the chunks of the stream
@since 0.3 *)
val to_chan : out_channel -> t -> unit
(** Write the stream to the channel.
@since 0.3 *)
val to_chan' : Tiny_httpd_io.Output.t -> t -> unit
(** Write to the IO channel.
@since 0.14 *)
val to_writer : t -> Tiny_httpd_io.Writer.t
(** Turn this stream into a writer.
@since 0.14 *)
val make :
?bs:bytes ->
?close:(t -> unit) ->
consume:(t -> int -> unit) ->
fill:(t -> unit) ->
unit ->
t
(** [make ~fill ()] creates a byte stream.
@param fill is used to refill the buffer, and is called initially.
@param close optional closing.
@param init_size size of the buffer.
*)
val with_file : ?buf_size:int -> string -> (t -> 'a) -> 'a
(** Open a file with given name, and obtain an input stream
on its content. When the function returns, the stream (and file) are closed. *)
val read_line : ?buf:Tiny_httpd_buf.t -> t -> string
(** Read a line from the stream.
@param buf a buffer to (re)use. Its content will be cleared. *)
val read_all : ?buf:Tiny_httpd_buf.t -> t -> string
(** Read the whole stream into a string.
@param buf a buffer to (re)use. Its content will be cleared. *)
val limit_size_to :
close_rec:bool -> max_size:int -> too_big:(int -> unit) -> t -> t
(* 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 *)
val read_chunked : ?buf:Tiny_httpd_buf.t -> fail:(string -> exn) -> t -> t
(** Convert a stream into a stream of byte chunks using
the chunked encoding. The size of chunks is not specified.
@param buf buffer used for intermediate storage.
@param fail used to build an exception if reading fails.
*)
val read_exactly :
close_rec:bool -> size:int -> too_short:(int -> unit) -> t -> t
(** [read_exactly ~size bs] returns a new stream that reads exactly
[size] bytes from [bs], and then closes.
@param close_rec if true, closing the resulting stream also closes
[bs]
@param too_short is called if [bs] closes with still [n] bytes remaining
*)
val output_chunked : ?buf:Tiny_httpd_buf.t -> out_channel -> t -> unit
(** Write the stream into the channel, using the chunked encoding.
@param buf optional buffer for chunking (since 0.14) *)
val output_chunked' :
?buf:Tiny_httpd_buf.t -> Tiny_httpd_io.Output.t -> t -> unit
(** Write the stream into the channel, using the chunked encoding.
@since 0.14 *)

121
src/Tiny_httpd_util.ml
View file

@ -1,121 +0,0 @@
let percent_encode ?(skip = fun _ -> false) s =
let buf = Buffer.create (String.length s) in
String.iter
(function
| c when skip c -> Buffer.add_char buf c
| ( ' ' | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '(' | ')' | '*' | '+'
| ',' | '/' | ':' | ';' | '=' | '?' | '@' | '[' | ']' | '~' ) as c ->
Printf.bprintf buf "%%%X" (Char.code c)
| c when Char.code c > 127 -> Printf.bprintf buf "%%%X" (Char.code c)
| c -> Buffer.add_char buf c)
s;
Buffer.contents buf
let int_of_hex_nibble = function
| '0' .. '9' as c -> Char.code c - Char.code '0'
| 'a' .. 'f' as c -> 10 + Char.code c - Char.code 'a'
| 'A' .. 'F' as c -> 10 + Char.code c - Char.code 'A'
| _ -> invalid_arg "string: invalid hex"
let percent_decode (s : string) : _ option =
let buf = Buffer.create (String.length s) in
let i = ref 0 in
try
while !i < String.length s do
match String.get s !i with
| '%' ->
if !i + 2 < String.length s then (
(match
(int_of_hex_nibble (String.get s (!i + 1)) lsl 4)
+ int_of_hex_nibble (String.get s (!i + 2))
with
| n -> Buffer.add_char buf (Char.chr n)
| exception _ -> raise Exit);
i := !i + 3
) else
raise Exit (* truncated *)
| '+' ->
Buffer.add_char buf ' ';
incr i (* for query strings *)
| c ->
Buffer.add_char buf c;
incr i
done;
Some (Buffer.contents buf)
with Exit -> None
exception Invalid_query
let find_q_index_ s = String.index s '?'
let get_non_query_path s =
match find_q_index_ s with
| i -> String.sub s 0 i
| exception Not_found -> s
let get_query s : string =
match find_q_index_ s with
| i -> String.sub s (i + 1) (String.length s - i - 1)
| exception Not_found -> ""
let split_query s = get_non_query_path s, get_query s
let split_on_slash s : _ list =
let l = ref [] in
let i = ref 0 in
let n = String.length s in
while !i < n do
match String.index_from s !i '/' with
| exception Not_found ->
if !i < n then (* last component *) l := String.sub s !i (n - !i) :: !l;
i := n (* done *)
| j ->
if j > !i then l := String.sub s !i (j - !i) :: !l;
i := j + 1
done;
List.rev !l
let parse_query s : (_ list, string) result =
let pairs = ref [] in
let is_sep_ = function
| '&' | ';' -> true
| _ -> false
in
let i = ref 0 in
let j = ref 0 in
try
let percent_decode s =
match percent_decode s with
| Some x -> x
| None -> raise Invalid_query
in
let parse_pair () =
let eq = String.index_from s !i '=' in
let k = percent_decode @@ String.sub s !i (eq - !i) in
let v = percent_decode @@ String.sub s (eq + 1) (!j - eq - 1) in
pairs := (k, v) :: !pairs
in
while !i < String.length s do
while !j < String.length s && not (is_sep_ (String.get s !j)) do
incr j
done;
if !j < String.length s then (
assert (is_sep_ (String.get s !j));
parse_pair ();
i := !j + 1;
j := !i
) else (
parse_pair ();
i := String.length s (* done *)
)
done;
Ok !pairs
with
| Invalid_argument _ | Not_found | Failure _ ->
Error (Printf.sprintf "error in parse_query for %S: i=%d,j=%d" s !i !j)
| Invalid_query -> Error ("invalid query string: " ^ s)
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

40
src/Tiny_httpd_util.mli
View file

@ -1,40 +0,0 @@
(** {1 Some utils for writing web servers}
@since 0.2
*)
val percent_encode : ?skip:(char -> bool) -> string -> string
(** Encode the string into a valid path following
https://tools.ietf.org/html/rfc3986#section-2.1
@param skip if provided, allows to preserve some characters, e.g. '/' in a path.
*)
val percent_decode : string -> string option
(** Inverse operation of {!percent_encode}.
Can fail since some strings are not valid percent encodings. *)
val split_query : string -> string * string
(** Split a path between the path and the query
@since 0.5 *)
val split_on_slash : string -> string list
(** Split a string on ['/'], remove the trailing ['/'] if any.
@since 0.6 *)
val get_non_query_path : string -> string
(** get the part of the path that is not the query parameters.
@since 0.5 *)
val get_query : string -> string
(** Obtain the query part of a path.
@since 0.4 *)
val parse_query : string -> ((string * string) list, string) result
(** Parse a query as a list of ['&'] or [';'] separated [key=value] pairs.
The order might not be preserved.
@since 0.3
*)
val show_sockaddr : Unix.sockaddr -> string
(** Simple printer for socket addresses.
@since NEXT_RELEASE *)

11
src/core/IO.ml
View file

@ -16,7 +16,7 @@ module Slice = Iostream.Slice
module Output = struct module Output = struct
include Iostream.Out_buf include Iostream.Out_buf
class of_fd ?(close_noerr = false) ~closed ~(buf : Slice.t) class of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
(fd : Unix.file_descr) : t = (fd : Unix.file_descr) : t =
object object
inherit t_from_output ~bytes:buf.bytes () inherit t_from_output ~bytes:buf.bytes ()
@ -203,7 +203,7 @@ module Input = struct
close i2 close i2
end end
let iter (f : Slice.t -> unit) (self : #t) : unit = let iter_slice (f : Slice.t -> unit) (self : #t) : unit =
let continue = ref true in let continue = ref true in
while !continue do while !continue do
let slice = self#fill_buf () in let slice = self#fill_buf () in
@ -216,14 +216,17 @@ module Input = struct
) )
done 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) = let to_chan oc (self : #t) =
iter iter_slice
(fun (slice : Slice.t) -> (fun (slice : Slice.t) ->
Stdlib.output oc slice.bytes slice.off slice.len) Stdlib.output oc slice.bytes slice.off slice.len)
self self
let to_chan' (oc : #Iostream.Out_buf.t) (self : #t) : unit = let to_chan' (oc : #Iostream.Out_buf.t) (self : #t) : unit =
iter iter_slice
(fun (slice : Slice.t) -> (fun (slice : Slice.t) ->
Iostream.Out_buf.output oc slice.bytes slice.off slice.len) Iostream.Out_buf.output oc slice.bytes slice.off slice.len)
self self

5
src/core/dune
View file

@ -2,11 +2,8 @@
(library (library
(name tiny_httpd_core) (name tiny_httpd_core)
(public_name tiny_httpd.core) (public_name tiny_httpd.core)
(private_modules mime_ parse_) (private_modules parse_)
(libraries threads seq hmap iostream (libraries threads seq hmap iostream
(select mime_.ml from
(magic-mime -> mime_.magic.ml)
( -> mime_.dummy.ml))
(select log.ml from (select log.ml from
(logs -> log.logs.ml) (logs -> log.logs.ml)
(-> log.default.ml)))) (-> log.default.ml))))

9
src/core/server.ml
View file

@ -83,11 +83,6 @@ type t = {
buf_pool: Buf.t Pool.t; buf_pool: Buf.t Pool.t;
} }
let get_addr_ sock =
match Unix.getsockname sock with
| Unix.ADDR_INET (addr, port) -> addr, port
| _ -> invalid_arg "httpd: address is not INET"
let addr (self : t) = let addr (self : t) =
match self.tcp_server with match self.tcp_server with
| None -> | None ->
@ -281,8 +276,6 @@ let create_from ?(buf_size = 16 * 1_024) ?(middlewares = []) ~backend () : t =
List.iter (fun (stage, m) -> add_middleware self ~stage m) middlewares; List.iter (fun (stage, m) -> add_middleware self ~stage m) middlewares;
self self
let is_ipv6_str addr : bool = String.contains addr ':'
let stop (self : t) = let stop (self : t) =
match self.tcp_server with match self.tcp_server with
| None -> () | None -> ()
@ -500,7 +493,7 @@ let client_handler (self : t) : IO.TCP_server.conn_handler =
let is_ipv6 (self : t) = let is_ipv6 (self : t) =
let (module B) = self.backend in let (module B) = self.backend in
is_ipv6_str (B.init_addr ()) Util.is_ipv6_str (B.init_addr ())
let run_exn ?(after_init = ignore) (self : t) : unit = let run_exn ?(after_init = ignore) (self : t) : unit =
let (module B) = self.backend in let (module B) = self.backend in

2
src/core/util.ml
View file

@ -119,3 +119,5 @@ let show_sockaddr = function
| Unix.ADDR_UNIX f -> f | Unix.ADDR_UNIX f -> f
| Unix.ADDR_INET (inet, port) -> | Unix.ADDR_INET (inet, port) ->
Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet) port Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet) port
let is_ipv6_str addr : bool = String.contains addr ':'

4
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 val show_sockaddr : Unix.sockaddr -> string
(** Simple printer for socket addresses. (** Simple printer for socket addresses.
@since NEXT_RELEASE *) @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 (library
(name tiny_httpd) (name tiny_httpd)
(public_name tiny_httpd) (public_name tiny_httpd)
(private_modules Tiny_httpd_mime_ Tiny_httpd_parse_) (flags :standard -open Tiny_httpd_core)
(libraries threads seq unix (libraries threads seq unix hmap tiny_httpd.core tiny_httpd.html
(select Tiny_httpd_mime_.ml from tiny_httpd.unix))
(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}))))

2
src/gen/dune
View file

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

517
src/gen/gentags.ml
View file

@ -1,517 +0,0 @@
(* adapted from https://github.com/sindresorhus/html-tags (MIT licensed) *)
let pf = Printf.printf
let spf = Printf.sprintf
let void =
[
"area";
"base";
"br";
"col";
"embed";
"hr";
"img";
"input";
"link";
"menuitem";
"meta";
"param";
"source";
"track";
"wbr";
]
let normal =
[
"a";
"abbr";
"address";
"area";
"article";
"aside";
"audio";
"b";
"base";
"bdi";
"bdo";
"blockquote";
"body";
"br";
"button";
"canvas";
"caption";
"cite";
"code";
"col";
"colgroup";
"data";
"datalist";
"dd";
"del";
"details";
"dfn";
"dialog";
"div";
"dl";
"dt";
"em";
"embed";
"fieldset";
"figcaption";
"figure";
"footer";
"form";
"h1";
"h2";
"h3";
"h4";
"h5";
"h6";
"head";
"header";
"hgroup";
"hr";
"html";
"i";
"iframe";
"img";
"input";
"ins";
"kbd";
"label";
"legend";
"li";
"link";
"main";
"map";
"mark";
"math";
"menu";
"menuitem";
"meta";
"meter";
"nav";
"noscript";
"object";
"ol";
"optgroup";
"option";
"output";
"p";
"param";
"picture";
"pre";
"progress";
"q";
"rb";
"rp";
"rt";
"rtc";
"ruby";
"s";
"samp";
"script";
"section";
"select";
"slot";
"small";
"source";
"span";
"strong";
"style";
"sub";
"summary";
"sup";
"svg";
"table";
"tbody";
"td";
"template";
"textarea";
"tfoot";
"th";
"thead";
"time";
"title";
"tr";
"track";
"u";
"ul";
"var";
"video";
"wbr";
]
|> List.filter (fun s -> not (List.mem s void))
(* obtained via:
{[
l = Array(...document.querySelectorAll('div tbody td code a')).map(
x => x.firstChild.textContent);
JSON.stringify(l)
]}
on https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes
*)
let attrs =
[
"accept";
"accept-charset";
"accesskey";
"action";
"align";
"allow";
"alt";
"async";
"autocapitalize";
"autocomplete";
"autofocus";
"autoplay";
"buffered";
"capture";
"challenge";
"charset";
"checked";
"cite";
"class";
"code";
"codebase";
"cols";
"colspan";
"content";
"contenteditable";
"contextmenu";
"controls";
"coords";
"crossorigin";
"csp";
"data";
"data-*";
"datetime";
"decoding";
"default";
"defer";
"dir";
"dirname";
"disabled";
"download";
"draggable";
"enctype";
"enterkeyhint";
"for";
"form";
"formaction";
"formenctype";
"formmethod";
"formnovalidate";
"formtarget";
"headers";
"hidden";
"high";
"href";
"hreflang";
"http-equiv";
"icon";
"id";
"importance";
"integrity";
"ismap";
"itemprop";
"keytype";
"kind";
"label";
"lang";
"language";
"list";
"loop";
"low";
"manifest";
"max";
"maxlength";
"minlength";
"media";
"method";
"min";
"multiple";
"muted";
"name";
"novalidate";
"open";
"optimum";
"pattern";
"ping";
"placeholder";
"poster";
"preload";
"radiogroup";
"readonly";
"referrerpolicy";
"rel";
"required";
"reversed";
"rows";
"rowspan";
"sandbox";
"scope";
"scoped";
"selected";
"shape";
"size";
"sizes";
"slot";
"span";
"spellcheck";
"src";
"srcdoc";
"srclang";
"srcset";
"start";
"step";
"style";
"summary";
"tabindex";
"target";
"title";
"translate";
"Text";
"type";
"usemap";
"value";
"width";
"wrap";
]
let prelude =
{|
(** Output for HTML combinators.
This output type is used to produce a string reasonably efficiently from
a tree of combinators.
{b NOTE}: this is experimental and an unstable API.
@since 0.12
@open *)
module Out : sig
type t
val create_of_buffer : Buffer.t -> t
val create_of_out: Tiny_httpd_io.Output.t -> t
val flush : t -> unit
val add_char : t -> char -> unit
val add_string : t -> string -> unit
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 *)
}
let create_of_out out = {out; fmt_nl=true}
let create_of_buffer buf : t = create_of_out (IO.Output.of_buffer buf)
let[@inline] flush self : unit = IO.Output.flush self.out
let[@inline] add_char self c = IO.Output.output_char self.out c
let[@inline] add_string self s = IO.Output.output_string self.out s
let[@inline] add_format_nl self = if self.fmt_nl then add_char self '\n'
let with_no_format_nl self f =
if self.fmt_nl then (
self.fmt_nl <- false;
try let x=f() in self.fmt_nl <- true; x with e -> self.fmt_nl <- true; raise e
) else f()
end
type attribute = string * string
(** An attribute, i.e. a key/value pair *)
type elt = Out.t -> unit
(** A html element. It is represented by its output function, so we
can directly print it. *)
type void = ?if_:bool -> attribute list -> elt
(** Element without children. *)
type nary = ?if_:bool -> attribute list -> elt list -> elt
(** Element with children, represented as a list.
@param if_ if false, do not print anything (default true) *)
(** A chunk of sub-elements, possibly empty.
@inline *)
type sub_elt = [ `E of elt | `L of elt list | `S of elt Seq.t | `Nil]
type nary' = ?if_:bool -> attribute list -> sub_elt list -> elt
(** Element with children, represented as a list of {!sub_elt} to be flattened
@param if_ if false, do not print anything (default true) *)
(**/**)
module Helpers_ = struct
(** Escape string so it can be safely embedded in HTML text. *)
let _str_escape (out:Out.t) (s:string) : unit =
String.iter (function
| '<' -> Out.add_string out "&lt;"
| '>' -> Out.add_string out "&gt;"
| '&' -> Out.add_string out "&amp;"
| '"' -> Out.add_string out "&quot;"
| '\'' -> Out.add_string out "&apos;"
| c -> Out.add_char out c)
s
(** Print the value part of an attribute *)
let _attr_escape (out:Out.t) (s:string) =
Out.add_char out '"';
_str_escape out s;
Out.add_char out '"'
(** Output a list of attributes. *)
let _write_attrs (out:Out.t) (l:attribute list) : unit =
List.iter
(fun (k,v) ->
Out.add_char out ' ';
Out.add_string out k;
Out.add_char out '=';
_attr_escape out v)
l
(** Write sub-elements of a {!nary'} element, returns [true] iff
at least one sub-element was written. *)
let _write_subs (out:Out.t) (l:sub_elt list) : bool =
let has_sub = ref false in
let prepend_white () = has_sub := true; Out.add_format_nl out; in
let emit1 = function
| `E x -> prepend_white(); x out
| `L l -> List.iter (fun e -> prepend_white(); e out) l
| `S l -> Seq.iter (fun e -> prepend_white(); e out) l
| `Nil -> ()
in
List.iter emit1 l;
!has_sub
(** Write a tag, with its attributes.
@param void if true, end with "/>", otherwise end with ">" *)
let _write_tag_attrs ~void (out:Out.t) (tag:string) (attrs:attribute list) : unit =
Out.add_string out "<";
Out.add_string out tag;
_write_attrs out attrs;
if void then Out.add_string out "/>" else Out.add_string out ">"
end
open Helpers_
(**/**)
(** Sub-element with a single element inside. *)
let[@inline] sub_e (elt:elt) : sub_elt = `E elt
(** Sub-element with a list of items inside. *)
let[@inline] sub_l (l:elt list) : sub_elt = `L l
(** Sub-element with a sequence ({!Seq.t}) of items inside. *)
let[@inline] sub_seq (l:elt Seq.t) : sub_elt = `S l
(** Helper to build a {!Seq.t} from an array. *)
let seq_of_array (a:_ array) : _ Seq.t =
let rec loop i () =
if i=Array.length a then Seq.Nil
else Seq.Cons (a.(i), loop (i+1))
in loop 0
(** Sub-element with nothing inside. Useful in conditionals, when one
decides not to emit a sub-element at all. *)
let sub_empty : sub_elt = `Nil
(** Emit a string value, which will be escaped. *)
let txt (txt:string) : elt = fun out -> _str_escape out txt
(** Formatted version of {!txt} *)
let txtf fmt = Format.kasprintf (fun s -> fun out -> _str_escape out s) fmt
(** Emit raw HTML. Caution, this can lead to injection vulnerabilities,
never use with text that comes from untrusted users. *)
let raw_html (s:string) : elt = fun out -> Out.add_string out s
|}
let oname = function
| "object" -> "object_"
| "class" -> "class_"
| "method" -> "method_"
| "data-*" -> "data_star"
| "for" -> "for_"
| "open" -> "open_"
| "Text" -> "text"
| "type" -> "type_"
| name ->
String.map
(function
| '-' -> '_'
| c -> c)
name
let emit_void name =
let oname = oname name in
pf
"(** tag %S, see \
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
name name;
pf "let %s : void = fun ?(if_=true) attrs out ->\n" oname;
pf " if if_ then (\n";
pf " _write_tag_attrs ~void:true out %S attrs;\n" name;
pf " )";
pf "\n\n";
()
let emit_normal name =
let oname = oname name in
pf
"(** tag %S, see \
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
name name;
pf "let %s : nary = fun ?(if_=true) attrs sub out ->\n" oname;
pf " if if_ then (\n";
(* for <pre>, newlines actually matter *)
if name = "pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
pf " _write_tag_attrs ~void:false out %S attrs;\n" name;
pf " List.iter (fun sub -> Out.add_format_nl out; sub out) sub;\n";
pf " if sub <> [] then Out.add_format_nl out;\n";
pf " Out.add_string out \"</%s>\")" name;
pf "\n\n";
(* block version *)
let oname = oname ^ "'" in
pf
"(** tag %S, see \
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
name name;
pf "let %s : nary' = fun ?(if_=true) attrs l out ->\n" oname;
pf " if if_ then (\n";
if name = "pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
pf " _write_tag_attrs ~void:false out %S attrs;\n" name;
pf " let has_sub = _write_subs out l in\n";
pf " if has_sub then Out.add_format_nl out;\n";
pf " Out.add_string out \"</%s>\")" name;
pf "\n\n";
()
let doc_attrs =
{|Attributes.
This module contains combinator for the standard attributes.
One can also just use a pair of strings. |}
let emit_attr name =
let oname = oname name in
pf " (** Attribute %S. *)\n" name;
pf " let %s : t = fun v -> %S, v\n" oname name;
pf "\n"
let () =
pf "%s\n" prelude;
List.iter emit_void void;
List.iter emit_normal normal;
pf "(** %s *)\n" doc_attrs;
pf "module A = struct\n";
pf " type t = string -> attribute\n";
pf " (** Attribute builder *)\n";
pf "\n";
List.iter emit_attr attrs;
pf "end\n";
()

41
src/gen/mkshims.ml
View file

@ -1,41 +0,0 @@
let atomic_before_412 =
{|
type 'a t = {mutable x: 'a}
let[@inline] make x = {x}
let[@inline] get {x} = x
let[@inline] set r x = r.x <- x
let[@inline] exchange r x =
let y = r.x in
r.x <- x;
y
let[@inline] compare_and_set r seen v =
if r.x == seen then (
r.x <- v;
true
) else false
let[@inline] fetch_and_add r x =
let v = r.x in
r.x <- x + r.x;
v
let[@inline] incr r = r.x <- 1 + r.x
let[@inline] decr r = r.x <- r.x - 1
|}
let atomic_after_412 = {|include Atomic|}
let write_file file s =
let oc = open_out file in
output_string oc s;
close_out oc
let () =
let version = Scanf.sscanf Sys.ocaml_version "%d.%d.%s" (fun x y _ -> x, y) in
print_endline
(if version >= (4, 12) then
atomic_after_412
else
atomic_before_412);
()

6
src/html/Tiny_httpd_html.ml
View file

@ -6,8 +6,6 @@
@since 0.12 @since 0.12
*) *)
module IO = Tiny_httpd_io
include Html_ include Html_
(** @inline *) (** @inline *)
@ -61,5 +59,5 @@ let to_writer ?top (self : elt) : IO.Writer.t =
(** Convert a HTML element to a stream. This might just convert (** Convert a HTML element to a stream. This might just convert
it to a string first, do not assume it to be more efficient. *) it to a string first, do not assume it to be more efficient. *)
let to_stream (self : elt) : Tiny_httpd_stream.t = let[@inline] to_stream (self : elt) : IO.Input.t =
Tiny_httpd_stream.of_string @@ to_string self IO.Input.of_string @@ to_string self

3
src/html/dune
View file

@ -3,7 +3,8 @@
(library (library
(name tiny_httpd_html) (name tiny_httpd_html)
(public_name tiny_httpd.html) (public_name tiny_httpd.html)
(libraries seq tiny_httpd.html)) (flags :standard -open Tiny_httpd_core)
(libraries seq tiny_httpd.core))
(rule (rule
(targets html_.ml) (targets html_.ml)

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

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

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

@ -1,7 +1,7 @@
module S = Tiny_httpd_server module S = Server
module U = Tiny_httpd_util module U = Util
module Html = Tiny_httpd_html module Html = Tiny_httpd_html
module Log = Tiny_httpd_log module Log = Log
type dir_behavior = Index | Lists | Index_or_lists | Forbidden type dir_behavior = Index | Lists | Index_or_lists | Forbidden
type hidden = unit type hidden = unit
@ -78,7 +78,7 @@ module type VFS = sig
val list_dir : string -> string array val list_dir : string -> string array
val delete : string -> unit val delete : string -> unit
val create : string -> (bytes -> int -> int -> unit) * (unit -> 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_size : string -> int option
val file_mtime : string -> float option val file_mtime : string -> float option
end end
@ -99,7 +99,8 @@ let vfs_of_dir (top : string) : vfs =
| { st_kind = Unix.S_REG; _ } -> | { st_kind = Unix.S_REG; _ } ->
let ic = Unix.(openfile fpath [ O_RDONLY ] 0) in let ic = Unix.(openfile fpath [ O_RDONLY ] 0) in
let closed = ref false 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) | _ -> failwith (Printf.sprintf "not a regular file: %S" f)
let create f = let create f =
@ -216,51 +217,51 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
: unit = : unit =
let route () = let route () =
if prefix = "" then if prefix = "" then
S.Route.rest_of_path_urlencoded Route.rest_of_path_urlencoded
else else
S.Route.exact_path prefix S.Route.rest_of_path_urlencoded Route.exact_path prefix Route.rest_of_path_urlencoded
in in
if config.delete then if config.delete then
S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req -> S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req ->
if contains_dot_dot path then 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 else
S.Response.make_string Response.make_string
(try (try
VFS.delete path; VFS.delete path;
Ok "file deleted successfully" Ok "file deleted successfully"
with e -> Error (500, Printexc.to_string e))) with e -> Error (500, Printexc.to_string e)))
else else
S.add_route_handler server ~meth:`DELETE (route ()) (fun _ _ -> 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 if config.upload then
S.add_route_handler_stream server ~meth:`PUT (route ()) S.add_route_handler_stream server ~meth:`PUT (route ())
~accept:(fun req -> ~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 -> | Some n when n > config.max_upload_size ->
Error Error
(403, "max upload size is " ^ string_of_int config.max_upload_size) (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 '..')") Error (403, "invalid path (contains '..')")
| _ -> Ok ()) | _ -> Ok ())
(fun path req -> (fun path req ->
let write, close = let write, close =
try VFS.create path try VFS.create path
with e -> 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) (Printexc.to_string e)
in in
let req = let req =
S.Request.limit_body_size ~max_size:config.max_upload_size req Request.limit_body_size ~max_size:config.max_upload_size req
in in
Tiny_httpd_stream.iter write req.S.Request.body; IO.Input.iter write req.Request.body;
close (); close ();
Log.debug (fun k -> k "dir: done uploading file to %S" path); 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 else
S.add_route_handler server ~meth:`PUT (route ()) (fun _ _ -> 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 if config.download then
S.add_route_handler server ~meth:`GET (route ()) (fun path req -> S.add_route_handler server ~meth:`GET (route ()) (fun path req ->
@ -268,19 +269,18 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
let mtime = let mtime =
lazy lazy
(match VFS.file_mtime path with (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) | Some t -> Printf.sprintf "mtime: %.4f" t)
in in
if contains_dot_dot path then 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 else if not (VFS.contains path) then
S.Response.fail ~code:404 "File not found" Response.fail ~code:404 "File not found"
else if else if Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
then ( then (
Log.debug (fun k -> Log.debug (fun k ->
k "dir: cached object %S (etag: %S)" path (Lazy.force mtime)); 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 ( ) else if VFS.is_directory path then (
Log.debug (fun k -> k "dir: list dir %S (topdir %S)" path VFS.descr); Log.debug (fun k -> k "dir: list dir %S (topdir %S)" path VFS.descr);
let parent = Filename.(dirname path) in let parent = Filename.(dirname path) in
@ -295,17 +295,17 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
(* redirect using path, not full path *) (* redirect using path, not full path *)
let new_path = "/" // prefix // path // "index.html" in let new_path = "/" // prefix // path // "index.html" in
Log.debug (fun k -> k "dir: redirect to `%s`" new_path); Log.debug (fun k -> k "dir: redirect to `%s`" new_path);
S.Response.make_void ~code:301 () Response.make_void ~code:301 ()
~headers:S.Headers.(empty |> set "location" new_path) ~headers:Headers.(empty |> set "location" new_path)
| Lists | Index_or_lists -> | Lists | Index_or_lists ->
let body = let body =
html_list_dir ~prefix vfs path ~parent |> Html.to_string_top html_list_dir ~prefix vfs path ~parent |> Html.to_string_top
in in
S.Response.make_string Response.make_string
~headers:[ header_html; "ETag", Lazy.force mtime ] ~headers:[ header_html; "ETag", Lazy.force mtime ]
(Ok body) (Ok body)
| Forbidden | Index -> | Forbidden | Index ->
S.Response.make_raw ~code:405 "listing dir not allowed" Response.make_raw ~code:405 "listing dir not allowed"
) else ( ) else (
try try
let mime_type = let mime_type =
@ -315,13 +315,13 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
[ "Content-Type", "text/javascript" ] [ "Content-Type", "text/javascript" ]
else if on_fs then ( else if on_fs then (
(* call "file" util *) (* 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 ] [ "content-type", ty ]
) else ) else
[] []
in in
let stream = VFS.read_file_content path 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 ]) ~headers:(mime_type @ [ "Etag", Lazy.force mtime ])
~code:200 stream ~code:200 stream
with e -> with e ->
@ -330,11 +330,11 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
Log.error (fun k -> Log.error (fun k ->
k "dir.get failed: %s@.%s" msg k "dir.get failed: %s@.%s" msg
(Printexc.raw_backtrace_to_string bt)); (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 else
S.add_route_handler server ~meth:`GET (route ()) (fun _ _ -> 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 = let add_vfs ~config ~vfs ~prefix server : unit =
@ -437,7 +437,7 @@ module Embedded_fs = struct
let read_file_content p = let read_file_content p =
match find_ self p with 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) | _ -> failwith (Printf.sprintf "no such file: %S" p)
let list_dir 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 *) @since 0.12 *)
val add_dir_path : 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 (** [add_dirpath ~config ~dir ~prefix server] adds route handle to the
[server] to serve static files in [dir] when url starts with [prefix], [server] to serve static files in [dir] when url starts with [prefix],
using the given configuration [config]. *) using the given configuration [config]. *)
@ -91,7 +91,7 @@ module type VFS = sig
val create : string -> (bytes -> int -> int -> unit) * (unit -> unit) val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
(** Create a file and obtain a pair [write, close] *) (** 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 *) (** Read content of a file *)
val file_size : string -> int option val file_size : string -> int option
@ -108,11 +108,7 @@ val vfs_of_dir : string -> (module VFS)
*) *)
val add_vfs : val add_vfs :
config:config -> config:config -> vfs:(module VFS) -> prefix:string -> Server.t -> unit
vfs:(module VFS) ->
prefix:string ->
Tiny_httpd_server.t ->
unit
(** Similar to {!add_dir_path} but using a virtual file system instead. (** Similar to {!add_dir_path} but using a virtual file system instead.
@since 0.12 @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/core/mime_.dummy.ml → src/unix/mime_.dummy.ml
View file

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

0
src/core/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.info (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.info (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

1
tiny_httpd.opam
View file

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

1
vendor/iostream vendored Submodule

@ -0,0 +1 @@
Subproject commit bb03b78fab03e9eb7186c45d33d23735650351ec