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

format code

Browse source
This commit is contained in:
Simon Cruanes 2025-05-01 13:40:03 -04:00
parent 2a7e597643
commit 365889557c
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
30 changed files with 514 additions and 511 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
examples/dune
View file

@ -12,7 +12,11 @@
(name echo)
(flags :standard -warn-error -a+8)
(modules echo vfs)
(libraries tiny_httpd logs tiny_httpd_camlzip tiny_httpd.multipart-form-data))
(libraries
tiny_httpd
logs
tiny_httpd_camlzip
tiny_httpd.multipart-form-data))
(executable
(name writer)

6
examples/echo.ml
View file

@ -142,12 +142,14 @@ let () =
"-p", Arg.Set_int port_, " set port";
"--debug", Arg.Unit setup_logging, " enable debug";
"-j", Arg.Set_int j, " maximum number of connections";
"--addr", Arg.Set_string addr, " binding address";
"--addr", Arg.Set_string addr, " binding address";
])
(fun _ -> raise (Arg.Bad ""))
"echo [option]*";
let server = Tiny_httpd.create ~addr:!addr ~port:!port_ ~max_connections:!j () in
let server =
Tiny_httpd.create ~addr:!addr ~port:!port_ ~max_connections:!j ()
in
Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16 * 1024) server;
let m_stats, get_stats = middleware_stat () in

6
examples/echo_ws.ml
View file

@ -6,9 +6,9 @@ let setup_logging ~debug () =
Logs.set_level ~all:true
@@ Some
(if debug then
Logs.Debug
else
Logs.Info)
Logs.Debug
else
Logs.Info)
let handle_ws (req : unit Request.t) ic oc =
Log.info (fun k ->

6
examples/sse_server.ml
View file

@ -36,9 +36,9 @@ let () =
EV.send_event
~event:
(if !tick then
"tick"
else
"tock")
"tick"
else
"tock")
~data:(Ptime.to_rfc3339 now) ();
tick := not !tick;

154
src/Tiny_httpd.mli
View file

@ -1,8 +1,8 @@
(** Tiny Http Server
This library implements a very simple, basic HTTP/1.1 server using blocking
IOs and threads. Basic routing based is provided for convenience,
so that several handlers can be registered.
IOs and threads. Basic routing based is provided for convenience, so that
several handlers can be registered.
It is possible to use a thread pool, see {!create}'s argument [new_thread].
@ -10,74 +10,71 @@
features by declaring a few endpoints, including one for uploading files:
{[
module S = Tiny_httpd
module S = Tiny_httpd
let () =
let server = S.create () in
let () =
let server = S.create () in
(* say hello *)
S.add_route_handler ~meth:`GET server
S.Route.(exact "hello" @/ string @/ return)
(fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n")));
(* say hello *)
S.add_route_handler ~meth:`GET server
S.Route.(exact "hello" @/ string @/ return)
(fun name _req ->
S.Response.make_string (Ok ("hello " ^ name ^ "!\n")));
(* echo request *)
S.add_route_handler server
S.Route.(exact "echo" @/ return)
(fun req -> S.Response.make_string
(Ok (Format.asprintf "echo:@ %a@." S.Request.pp req)));
(* echo request *)
S.add_route_handler server
S.Route.(exact "echo" @/ return)
(fun req ->
S.Response.make_string
(Ok (Format.asprintf "echo:@ %a@." S.Request.pp req)));
(* file upload *)
S.add_route_handler ~meth:`PUT server
S.Route.(exact "upload" @/ string_urlencoded @/ return)
(fun path req ->
try
let oc = open_out @@ "/tmp/" ^ path in
output_string oc req.S.Request.body;
flush oc;
S.Response.make_string (Ok "uploaded file")
with e ->
S.Response.fail ~code:500 "couldn't upload file: %s"
(Printexc.to_string e)
);
(* file upload *)
S.add_route_handler ~meth:`PUT server
S.Route.(exact "upload" @/ string_urlencoded @/ return)
(fun path req ->
try
let oc = open_out @@ "/tmp/" ^ path in
output_string oc req.S.Request.body;
flush oc;
S.Response.make_string (Ok "uploaded file")
with e ->
S.Response.fail ~code:500 "couldn't upload file: %s"
(Printexc.to_string e));
(* run the server *)
Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
match S.run server with
| Ok () -> ()
| Error e -> raise e
(* run the server *)
Printf.printf "listening on http://%s:%d\n%!" (S.addr server)
(S.port server);
match S.run server with
| Ok () -> ()
| Error e -> raise e
]}
It is then possible to query it using curl:
{[
$ dune exec src/examples/echo.exe &
listening on http://127.0.0.1:8080
$ dune exec src/examples/echo.exe &
listening on http://127.0.0.1:8080
# the path "hello/name" greets you.
$ curl -X GET http://localhost:8080/hello/quadrarotaphile
hello quadrarotaphile!
# the path "hello/name" greets you.
$ curl -X GET http://localhost:8080/hello/quadrarotaphile
hello quadrarotaphile!
# the path "echo" just prints the request.
$ curl -X GET http://localhost:8080/echo --data "howdy y'all"
echo:
{meth=GET;
headers=Host: localhost:8080
User-Agent: curl/7.66.0
Accept: */*
Content-Length: 10
Content-Type: application/x-www-form-urlencoded;
path="/echo"; body="howdy y'all"}
]}
*)
# the path "echo" just prints the request.
$ curl -X GET http://localhost:8080/echo --data "howdy y'all"
echo:
{meth=GET;
headers=Host: localhost:8080
User-Agent: curl/7.66.0
Accept: */*
Content-Length: 10
Content-Type: application/x-www-form-urlencoded;
path="/echo"; body="howdy y'all"}
]} *)
(** {2 Tiny buffer implementation}
These buffers are used to avoid allocating too many byte arrays when
processing streams and parsing requests.
*)
processing streams and parsing requests. *)
module Buf = Buf
@ -141,37 +138,42 @@ val create :
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.
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] except when on Windows, which defaults to [false].
@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]
except when on Windows, which defaults to [false].
@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 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 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 enable_logging if true and [Logs] is installed, log requests. Default true.
This parameter exists since 0.18. Does not affect debug-level logs.
@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 enable_logging
if true and [Logs] is installed, log requests. Default true. This
parameter exists since 0.18. Does not affect debug-level logs.
@param get_time_s obtain the current timestamp in seconds.
This parameter exists since 0.11.
@param get_time_s
obtain the current timestamp in seconds. This parameter exists since 0.11.
*)

10
src/bin/curly.ml
View file

@ -1,8 +1,8 @@
module Result = struct
include Result
let ( >>= ) :
type a b e. (a, e) result -> (a -> (b, e) result) -> (b, e) result =
let ( >>= ) : type a b e.
(a, e) result -> (a -> (b, e) result) -> (b, e) result =
fun r f ->
match r with
| Ok x -> f x
@ -121,9 +121,9 @@ module Request = struct
Header.to_cmd t.headers;
[ t.url ];
(if has_body t then
[ "--data-binary"; "@-" ]
else
[]);
[ "--data-binary"; "@-" ]
else
[]);
]
let pp fmt t =

22
src/camlzip/Tiny_httpd_camlzip.mli
View file

@ -1,22 +1,22 @@
(** Middleware for compression.
This uses camlzip to provide deflate compression/decompression.
If installed, the middleware will compress responses' bodies
when they are streams or fixed-size above a given limit
(but it will not compress small, fixed-size bodies).
*)
This uses camlzip to provide deflate compression/decompression. If
installed, the middleware will compress responses' bodies when they are
streams or fixed-size above a given limit (but it will not compress small,
fixed-size bodies). *)
val middleware :
?compress_above:int -> ?buf_size:int -> unit -> Server.Middleware.t
(** Middleware responsible for deflate compression/decompression.
@param compress_above threshold, in bytes, above which a response body
that has a known content-length is compressed. Stream bodies
are always compressed.
@param compress_above
threshold, in bytes, above which a response body that has a known
content-length is compressed. Stream bodies are always compressed.
@param buf_size size of the underlying buffer for compression/decompression
@since 0.11 *)
val setup : ?compress_above:int -> ?buf_size:int -> Server.t -> unit
(** Install middleware for tiny_httpd to be able to encode/decode
compressed streams
(** Install middleware for tiny_httpd to be able to encode/decode compressed
streams
@param compress_above threshold above with string responses are compressed
@param buf_size size of the underlying buffer for compression/decompression *)
@param buf_size size of the underlying buffer for compression/decompression
*)

67
src/core/IO.ml
View file

@ -1,12 +1,11 @@
(** IO abstraction.
We abstract IO so we can support classic unix blocking IOs
with threads, and modern async IO with Eio.
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
*)
@since 0.14 *)
open Common_
module Buf = Buf
@ -17,7 +16,8 @@ module Output = struct
include Iostream.Out_buf
class of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
(fd : Unix.file_descr) : t =
(fd : Unix.file_descr) :
t =
object
inherit t_from_output ~bytes:buf.bytes ()
@ -62,10 +62,10 @@ module Output = struct
(** [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.
*)
@param buf
a buffer used to accumulate data into chunks. Chunks are emitted when
[buf]'s size gets over a certain threshold, or when [flush] is called.
*)
let chunk_encoding ?(buf = Buf.create ()) ~close_rec (oc : #t) : t =
(* write content of [buf] as a chunk if it's big enough.
If [force=true] then write content of [buf] if it's simply non empty. *)
@ -301,14 +301,14 @@ module Input = struct
end
(** new stream with maximum size [max_size].
@param close_rec if true, closing this will also close the input stream *)
@param close_rec if true, closing this will also close the input stream *)
let limit_size_to ~close_rec ~max_size ~bytes (arg : t) : t =
reading_exactly_ ~size:max_size ~skip_on_close:false ~bytes ~close_rec arg
(** New stream that consumes exactly [size] bytes from the input.
If fewer bytes are read before [close] is called, we read and discard
the remaining quota of bytes before [close] returns.
@param close_rec if true, closing this will also close the input stream *)
(** New stream that consumes exactly [size] bytes from the input. If fewer
bytes are read before [close] is called, we read and discard the remaining
quota of bytes before [close] returns.
@param close_rec if true, closing this will also close the input stream *)
let reading_exactly ~close_rec ~size ~bytes (arg : t) : t =
reading_exactly_ ~size ~close_rec ~skip_on_close:true ~bytes arg
@ -394,16 +394,15 @@ 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.
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
*)
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 }
@ -432,32 +431,32 @@ module TCP_server = struct
type t = {
endpoint: unit -> string * int;
(** Endpoint we listen on. This can only be called from within [serve]. *)
(** 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]. *)
(** 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. *)
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. *)
@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. *)
an unspecified endpoint (most likely coming from the function returning
this builder) and returns the running server. *)
end

3
src/core/buf.mli
View file

@ -3,8 +3,7 @@
These buffers are used to avoid allocating too many byte arrays when
processing streams and parsing requests.
@since 0.12
*)
@since 0.12 *)
type t

6
src/core/gen/mkshims.ml
View file

@ -35,7 +35,7 @@ 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);
atomic_after_412
else
atomic_before_412);
()

12
src/core/headers.mli
View file

@ -5,23 +5,23 @@
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 *)
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 *)
@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. *)
@param f if provided, will transform the value before it is returned. *)
val get_exn : ?f:(string -> string) -> string -> t -> string
(** @raise Not_found *)
val set : string -> string -> t -> t
(** [set k v headers] sets the key [k] to value [v].
It erases any previous entry for [k] *)
(** [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. *)

10
src/core/log.mli
View file

@ -5,13 +5,13 @@ 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.
(** 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
val fully_disable : unit -> unit
(** Totally silence logs for tiny_httpd. With [Logs] installed this means setting
the level of the tiny_httpd source to [None].
@since 0.18 *)
(** Totally silence logs for tiny_httpd. With [Logs] installed this means
setting the level of the tiny_httpd source to [None].
@since 0.18 *)

5
src/core/meth.mli
View file

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

28
src/core/pool.mli
View file

@ -1,9 +1,9 @@
(** 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.
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. *)
@ -14,20 +14,18 @@ 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.
*)
@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. *)
(** [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. *)
(** Low level control over the pool.
This is easier to get wrong (e.g. releasing the same resource twice)
so use with caution.
@since 0.18 *)
(** Low level control over the pool. This is easier to get wrong (e.g. releasing
the same resource twice) so use with caution.
@since 0.18 *)
module Raw : sig
val acquire : 'a t -> 'a
val release : 'a t -> 'a -> unit

63
src/core/request.mli
View file

@ -1,7 +1,7 @@
(** 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. *)
Requests are sent by a client, e.g. a web browser or cURL. From the point of
view of the server, they're inputs. *)
open Common_
@ -21,33 +21,32 @@ type 'body t = private {
body: 'body; (** Body of the request. *)
start_time: float;
(** Obtained via [get_time_s] in {!create}
@since 0.11 *)
@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}.
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
*)
@since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"]
@since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"].
@since 0.11 the type is a private alias
@since 0.11 the field [start_time] was added *)
val add_meta : _ t -> 'a Hmap.key -> 'a -> unit
(** Add metadata
@since 0.17 *)
@since 0.17 *)
val get_meta : _ t -> 'a Hmap.key -> 'a option
(** Get metadata
@since 0.17 *)
@since 0.17 *)
val get_meta_exn : _ t -> 'a Hmap.key -> 'a
(** Like {!get_meta} but can fail
@raise Invalid_argument if not present
@since 0.17 *)
@since 0.17 *)
val pp_with :
?mask_header:(string -> bool) ->
@ -71,20 +70,20 @@ val pp_with :
which works even for stream bodies) *)
val pp : Format.formatter -> string t -> unit
(** Pretty print the request and its body. The exact format of this printing
is not specified. *)
(** 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. *)
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]. *)
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. *)
@ -94,22 +93,22 @@ val set_header : string -> string -> 'a t -> 'a t
val remove_header : string -> 'a t -> 'a t
(** Remove one instance of this header.
@since 0.17 *)
@since 0.17 *)
val update_headers : (Headers.t -> Headers.t) -> 'a t -> 'a t
(** Modify headers using the given function.
@since 0.11 *)
@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 *)
@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 *)
@since 0.16 *)
val meth : _ t -> Meth.t
(** Method for the request. *)
@ -119,28 +118,26 @@ val path : _ t -> string
val query : _ t -> (string * string) list
(** Decode the query part of the {!path} field.
@since 0.4 *)
@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 *)
(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the
request
@since 0.11 *)
val limit_body_size :
max_size:int -> bytes:bytes -> IO.Input.t t -> IO.Input.t t
(** Limit the body size to [max_size] bytes, or return
a [413] error.
@since 0.3
*)
(** Limit the body size to [max_size] bytes, or return a [413] error.
@since 0.3 *)
val read_body_full : ?bytes:bytes -> ?buf_size:int -> IO.Input.t t -> string t
(** Read the whole body into a string. Potentially blocking.
@param buf_size initial size of underlying buffer (since 0.11)
@param bytes the initial buffer (since 0.14)
*)
@param bytes the initial buffer (since 0.14) *)
(**/**)

85
src/core/response.mli
View file

@ -1,65 +1,66 @@
(** Responses
Responses are what a http server, such as {!Tiny_httpd}, send back to
the client to answer a {!Request.t}*)
Responses are what a http server, such as {!Tiny_httpd}, send back to the
client to answer a {!Request.t}*)
type body =
[ `String of string | `Stream of IO.Input.t | `Writer of IO.Writer.t | `Void ]
(** Body of a response, either as a simple string,
or a stream of bytes, or nothing (for server-sent events notably).
(** 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.
*)
- [`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. *)
(** 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 *)
@since 0.11 *)
val set_header : string -> string -> t -> t
(** Set a header.
@since 0.11 *)
@since 0.11 *)
val update_headers : (Headers.t -> Headers.t) -> t -> t
(** Modify headers.
@since 0.11 *)
@since 0.11 *)
val remove_header : string -> t -> t
(** Remove one instance of this header.
@since 0.17 *)
@since 0.17 *)
val set_headers : Headers.t -> t -> t
(** Set all headers.
@since 0.11 *)
@since 0.11 *)
val set_code : Response_code.t -> t -> t
(** Set the response code.
@since 0.11 *)
@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. *)
(** Make a response from its raw components, with a string body. Use [""] to not
send a body at all. *)
val make_raw_stream :
?headers:Headers.t -> code:Response_code.t -> IO.Input.t -> t
(** Same as {!make_raw} but with a stream body. The body will be sent with
the chunked transfer-encoding. *)
(** 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 *)
@since 0.13 *)
val make :
?headers:Headers.t ->
@ -68,10 +69,9 @@ val make :
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.
*)
- [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 ->
@ -95,19 +95,17 @@ val make_stream :
(** 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"].
*)
(** Make the current request fail with the given code and message. Example:
[fail ~code:404 "oh noes, %s not found" "waldo"]. *)
exception Bad_req of int * string
(** Exception raised by {!fail_raise} with the HTTP code and body *)
val fail_raise : code:int -> ('a, unit, string, 'b) format4 -> 'a
(** Similar to {!fail} but raises an exception that exits the current handler.
This should not be used outside of a (path) handler.
Example: [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
@raise Bad_req always
*)
This should not be used outside of a (path) handler. Example:
[fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
@raise Bad_req always *)
val pp_with :
?mask_header:(string -> bool) ->
@ -117,15 +115,16 @@ val pp_with :
Format.formatter ->
t ->
unit
(** Pretty print the response. The exact format of this printing
is not specified.
@param mask_header function which is given each header name. If it
returns [true], the header's value is masked. The presence of
the header is still printed. Default [fun _ -> false].
@param headers_to_mask a list of headers masked by default.
Default is ["set-cookie"].
@param pp_body body printer
(default fully prints String bodies, but omits stream bodies)
(** Pretty print the response. The exact format of this printing is not
specified.
@param mask_header
function which is given each header name. If it returns [true], the
header's value is masked. The presence of the header is still printed.
Default [fun _ -> false].
@param headers_to_mask
a list of headers masked by default. Default is ["set-cookie"].
@param pp_body
body printer (default fully prints String bodies, but omits stream bodies)
@since 0.18 *)
val pp : Format.formatter -> t -> unit

8
src/core/response_code.mli
View file

@ -3,7 +3,7 @@
type t = int
(** A standard HTTP code.
https://tools.ietf.org/html/rfc7231#section-6 *)
https://tools.ietf.org/html/rfc7231#section-6 *)
val ok : t
(** The code [200] *)
@ -12,9 +12,9 @@ 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). *)
(** 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 0.17 *)
@since 0.17 *)

6
src/core/route.ml
View file

@ -73,9 +73,9 @@ let rec pp_ : type a b. Buffer.t -> (a, b) t -> unit =
| Rest { url_encoded } ->
bpf out "<rest_of_url%s>"
(if url_encoded then
"_urlencoded"
else
"")
"_urlencoded"
else
"")
| Compose (Exact s, tl) -> bpf out "%s/%a" s pp_ tl
| Compose (Int, tl) -> bpf out "<int>/%a" pp_ tl
| Compose (String, tl) -> bpf out "<str>/%a" pp_ tl

30
src/core/route.mli
View file

@ -1,8 +1,8 @@
(** 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}.
Basic type-safe routing of handlers based on URL paths. This is optional, it
is possible to only define the root handler with something like
{{:https://github.com/anuragsoni/routes/} Routes}.
@since 0.6 *)
type ('a, 'b) comp
@ -27,31 +27,31 @@ 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 *)
(** 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 ['/'], and URL-decode it (piecewise).
This will match the entirety of the remaining route.
@since 0.7 *)
(** Matches a string, even containing ['/'], and URL-decode it (piecewise). 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/…"]. *)
(** [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 **)
[exact "foo" @/ exact "bar" @/ ... @/ r]
@since 0.11 **)
val pp : Format.formatter -> _ t -> unit
(** Print the route.
@since 0.7 *)
@since 0.7 *)
val to_string : _ t -> string
(** Print the route.
@since 0.7 *)
@since 0.7 *)
module Private_ : sig
val eval : string list -> ('a, 'b) t -> 'a -> 'b option

6
src/core/server.ml
View file

@ -50,8 +50,8 @@ module type UPGRADE_HANDLER = sig
Unix.sockaddr ->
unit Request.t ->
(Headers.t * handshake_state, string) result
(** Perform the handshake and upgrade the connection. The returned
code is [101] alongside these headers. *)
(** Perform the handshake and upgrade the connection. The returned code is
[101] alongside these headers. *)
val handle_connection : handshake_state -> IO.Input.t -> IO.Output.t -> unit
(** Take control of the connection and take it from there *)
@ -69,7 +69,7 @@ module type IO_BACKEND = sig
(** obtain the current timestamp in seconds. *)
val tcp_server : unit -> IO.TCP_server.builder
(** Server that can listen on a port and handle clients. *)
(** Server that can listen on a port and handle clients. *)
end
type handler_result =

213
src/core/server.mli
View file

@ -5,33 +5,28 @@
It is possible to use a thread pool, see {!create}'s argument [new_thread].
@since 0.13
*)
@since 0.13 *)
exception Bad_req of int * string
(** Exception raised to exit request handlers with a code+error message *)
(** {2 Middlewares}
A middleware can be inserted in a handler to modify or observe
its behavior.
A middleware can be inserted in a handler to modify or observe its behavior.
@since 0.11
*)
@since 0.11 *)
module Middleware : sig
type handler = IO.Input.t Request.t -> resp:(Response.t -> unit) -> unit
(** Handlers are functions returning a response to a request.
The response can be delayed, hence the use of a continuation
as the [resp] parameter. *)
(** 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. *)
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. *)
@ -39,14 +34,14 @@ end
(** A middleware that only considers the request's head+headers.
These middlewares are simpler than full {!Middleware.t} and
work in more contexts.
These middlewares are simpler than full {!Middleware.t} and work in more
contexts.
@since 0.17 *)
module Head_middleware : sig
type t = { handle: 'a. 'a Request.t -> 'a Request.t }
(** A handler that takes the request, without its body,
and possibly modifies it.
@since 0.17 *)
(** A handler that takes the request, without its body, and possibly modifies
it.
@since 0.17 *)
val trivial : t
(** Pass through *)
@ -62,9 +57,9 @@ type t
(** 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. *)
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 *)
@ -76,8 +71,8 @@ module type IO_BACKEND = sig
(** Obtain the current timestamp in seconds. *)
val tcp_server : unit -> IO.TCP_server.builder
(** TCP server builder, to create servers that can listen
on a port and handle clients. *)
(** TCP server builder, to create servers that can listen on a port and handle
clients. *)
end
val create_from :
@ -90,31 +85,31 @@ val create_from :
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.
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 head_middlewares see {!add_head_middleware} for details (since 0.18)
@param middlewares see {!add_middleware} for more details.
@param enable_logging if true and [Logs] is installed,
emit logs via Logs (since 0.18).
Default [true].
@param enable_logging
if true and [Logs] is installed, emit logs via Logs (since 0.18). Default
[true].
@since 0.14
*)
@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.
(** [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). *)
(** 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. *)
@ -124,40 +119,35 @@ val add_decode_request_cb :
(unit Request.t -> (unit Request.t * (IO.Input.t -> IO.Input.t)) option) ->
unit
[@@deprecated "use add_middleware"]
(** Add a callback for every request.
The callback can provide a stream transformer and a new request (with
modified headers, typically).
A possible use is to handle decompression by looking for a [Transfer-Encoding]
header and returning a stream transformer that decompresses on the fly.
(** 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
*)
@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.
(** 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
*)
@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.
@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
*)
@since 0.11 *)
val add_head_middleware : t -> Head_middleware.t -> unit
(** Add a request-header only {!Head_middleware.t}.
This is called on requests, to modify them, and returns a new request
immediately.
(** Add a request-header only {!Head_middleware.t}. This is called on requests,
to modify them, and returns a new request immediately.
@since 0.18 *)
(** {2 Request handlers} *)
@ -166,13 +156,12 @@ val set_top_handler : t -> (IO.Input.t Request.t -> Response.t) -> unit
(** Setup a handler called by default.
This handler is called with any request not accepted by any handler
installed via {!add_path_handler}.
If no top handler is installed, unhandled paths will return a [404] not found
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.
*)
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) ->
@ -183,23 +172,24 @@ val add_route_handler :
'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.
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.
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.
@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
*)
@since 0.6 *)
val add_route_handler_stream :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
@ -209,10 +199,10 @@ val add_route_handler_stream :
('a, IO.Input.t Request.t -> Response.t) Route.t ->
'a ->
unit
(** Similar to {!add_route_handler}, but where the body of the request
is a stream of bytes that has not been read yet.
This is useful when one wants to stream the body directly into a parser,
json decoder (such as [Jsonm]) or into a file.
(** 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}
@ -221,23 +211,23 @@ val add_route_handler_stream :
(** 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}.
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
*)
@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). *)
(** 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. *)
(** 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.
@ -245,8 +235,8 @@ module type SERVER_SENT_GENERATOR = sig
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).
(** 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 :
@ -258,12 +248,11 @@ val add_route_server_sent_handler :
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.
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).
@ -275,7 +264,7 @@ val add_route_server_sent_handler :
@since 0.17 *)
(** Handler that upgrades to another protocol.
@since 0.17 *)
@since 0.17 *)
module type UPGRADE_HANDLER = sig
type handshake_state
(** Some specific state returned after handshake *)
@ -288,11 +277,11 @@ module type UPGRADE_HANDLER = sig
unit Request.t ->
(Headers.t * handshake_state, string) result
(** Perform the handshake and upgrade the connection. This returns either
[Ok (resp_headers, state)] in case of success, in which case the
server sends a [101] response with [resp_headers];
or it returns [Error log_msg] if the the handshake fails, in which case
the connection is closed without further ado and [log_msg] is logged
locally (but not returned to the client). *)
[Ok (resp_headers, state)] in case of success, in which case the server
sends a [101] response with [resp_headers]; or it returns [Error log_msg]
if the the handshake fails, in which case the connection is closed without
further ado and [log_msg] is logged locally (but not returned to the
client). *)
val handle_connection : handshake_state -> IO.Input.t -> IO.Output.t -> unit
(** Take control of the connection and take it from ther.e *)
@ -316,16 +305,16 @@ val running : t -> bool
@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. *)
(** 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.
(** 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.
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 .
*)

18
src/core/util.mli
View file

@ -1,17 +1,16 @@
(** {1 Some utils for writing web servers}
@since 0.2
*)
@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.
*)
@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. *)
(** 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
@ -30,10 +29,9 @@ val get_query : string -> string
@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
*)
(** 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.

33
src/html/Tiny_httpd_html.ml
View file

@ -1,19 +1,18 @@
(** 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
*)
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 *)
include 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
*)
@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";
@ -22,18 +21,18 @@ let to_output ?(top = false) (self : elt) (out : #IO.Output.t) : unit =
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. *)
@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. *)
(** 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
@ -57,7 +56,7 @@ let to_writer ?top (self : elt) : IO.Writer.t =
let write (oc : #IO.Output.t) = to_output ?top self oc in
IO.Writer.make ~write ()
(** Convert a HTML element to a stream. This might just convert
it to a string first, do not assume it to be more efficient. *)
(** 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[@inline] to_stream (self : elt) : IO.Input.t =
IO.Input.of_string @@ to_string self

29
src/prometheus/tiny_httpd_prometheus.mli
View file

@ -1,11 +1,10 @@
(** Expose metrics over HTTP in the prometheus format.
This sub-library [tiny_httpd.prometheus] provides definitions
for counters, gauges, and histogram, and endpoints to expose
them for {{: https://prometheus.io/} Prometheus} to scrape them.
This sub-library [tiny_httpd.prometheus] provides definitions for counters,
gauges, and histogram, and endpoints to expose them for
{{:https://prometheus.io/} Prometheus} to scrape them.
@since 0.16
*)
@since 0.16 *)
type tags = (string * string) list
@ -17,13 +16,13 @@ module Registry : sig
val create : unit -> t
val on_will_emit : t -> (unit -> unit) -> unit
(** [on_will_emit registry f] calls [f()] every time
[emit buf registry] is called (before the metrics start being emitted). This
is useful to update some metrics on demand. *)
(** [on_will_emit registry f] calls [f()] every time [emit buf registry] is
called (before the metrics start being emitted). This is useful to update
some metrics on demand. *)
val emit : Buffer.t -> t -> unit
(** Write metrics into the given buffer. The buffer will be
cleared first thing. *)
(** Write metrics into the given buffer. The buffer will be cleared first
thing. *)
val emit_str : t -> string
end
@ -40,8 +39,8 @@ module Counter : sig
val incr_by : t -> int -> unit
val incr_to : t -> int -> unit
(** Increment to the given number. If it's lower than the current
value this does nothing *)
(** Increment to the given number. If it's lower than the current value this
does nothing *)
end
(** Gauges *)
@ -88,7 +87,7 @@ module GC_metrics : sig
val update : t -> unit
val create_and_update_before_emit : Registry.t -> unit
(** [create_and_update_before_emit reg] creates new GC metrics,
adds them to the registry, and uses {!Registry.on_will_emit}
to {!update} the metrics every time the registry is polled. *)
(** [create_and_update_before_emit reg] creates new GC metrics, adds them to
the registry, and uses {!Registry.on_will_emit} to {!update} the metrics
every time the registry is polled. *)
end

36
src/unix/dir.ml
View file

@ -151,9 +151,9 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt =
[
sub_e @@ a [ A.href ("/" // prefix // fpath) ] [ txt f ];
(if VFS.is_directory fpath then
sub_e @@ txt "[dir]"
else
sub_empty);
sub_e @@ txt "[dir]"
else
sub_empty);
sub_e @@ txt size;
])
)
@ -176,21 +176,21 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt =
@@ ul' []
[
(if !n_hidden > 0 then
sub_e
@@ details' []
[
sub_e
@@ summary [] [ txtf "(%d hidden files)" !n_hidden ];
sub_seq
(seq_of_array entries
|> Seq.filter_map (fun f ->
if is_hidden f then
file_to_elt f
else
None));
]
else
sub_empty);
sub_e
@@ details' []
[
sub_e
@@ summary [] [ txtf "(%d hidden files)" !n_hidden ];
sub_seq
(seq_of_array entries
|> Seq.filter_map (fun f ->
if is_hidden f then
file_to_elt f
else
None));
]
else
sub_empty);
sub_seq
(seq_of_array entries
|> Seq.filter_map (fun f ->

81
src/unix/dir.mli
View file

@ -1,29 +1,30 @@
(** Serving static content from directories
This module provides the same functionality as the "http_of_dir" tool.
It exposes a directory (and its subdirectories), with the optional ability
to delete or upload files.
This module provides the same functionality as the "http_of_dir" tool. It
exposes a directory (and its subdirectories), with the optional ability to
delete or upload files.
@since 0.11 *)
(** behavior of static directory.
This controls what happens when the user requests the path to
a directory rather than a file. *)
This controls what happens when the user requests the path to a directory
rather than a file. *)
type dir_behavior =
| Index (** Redirect to index.html if present, else fails. *)
| Lists
(** Lists content of directory. Be careful of security implications. *)
| Index_or_lists
(** Redirect to index.html if present and lists content otherwise.
This is useful for tilde ("~") directories and other per-user behavior,
but be mindful of security implications *)
(** Redirect to index.html if present and lists content otherwise. This is
useful for tilde ("~") directories and other per-user behavior, but be
mindful of security implications *)
| Forbidden
(** Forbid access to directory. This is suited for serving assets, for example. *)
(** Forbid access to directory. This is suited for serving assets, for
example. *)
type hidden
(** Type used to prevent users from building a config directly.
Use {!default_config} or {!config} instead. *)
(** Type used to prevent users from building a config directly. Use
{!default_config} or {!config} instead. *)
type config = {
mutable download: bool; (** Is downloading files allowed? *)
@ -32,21 +33,17 @@ type config = {
mutable delete: bool; (** Is deleting a file allowed? (with method DELETE) *)
mutable upload: bool; (** Is uploading a file allowed? (with method PUT) *)
mutable max_upload_size: int;
(** If {!upload} is true, this is the maximum size in bytes for
uploaded files. *)
(** If {!upload} is true, this is the maximum size in bytes for uploaded
files. *)
_rest: hidden; (** Just ignore this field. *)
}
(** configuration for static file handlers. This might get
more fields over time. *)
(** configuration for static file handlers. This might get more fields over
time. *)
val default_config : unit -> config
(** default configuration: [
{ download=true
; dir_behavior=Forbidden
; delete=false
; upload=false
; max_upload_size = 10 * 1024 * 1024
}] *)
(** default configuration:
[ { download=true ; dir_behavior=Forbidden ; delete=false ; upload=false ;
max_upload_size = 10 * 1024 * 1024 }] *)
val config :
?download:bool ->
@ -61,16 +58,15 @@ val config :
val add_dir_path :
config:config -> dir:string -> prefix:string -> Server.t -> unit
(** [add_dirpath ~config ~dir ~prefix server] adds route handle to the
[server] to serve static files in [dir] when url starts with [prefix],
using the given configuration [config]. *)
(** [add_dirpath ~config ~dir ~prefix server] adds route handle to the [server]
to serve static files in [dir] when url starts with [prefix], using the
given configuration [config]. *)
(** Virtual file system.
This is used to emulate a file system from pure OCaml functions and data,
e.g. for resources bundled inside the web server.
@since 0.12
*)
@since 0.12 *)
module type VFS = sig
val descr : string
(** Description of the VFS *)
@ -78,12 +74,12 @@ module type VFS = sig
val is_directory : string -> bool
val contains : string -> bool
(** [file_exists vfs path] returns [true] if [path] points to a file
or directory inside [vfs]. *)
(** [file_exists vfs path] returns [true] if [path] points to a file or
directory inside [vfs]. *)
val list_dir : string -> string array
(** List directory. This only returns basenames, the files need
to be put in the directory path using {!Filename.concat}. *)
(** List directory. This only returns basenames, the files need to be put in
the directory path using {!Filename.concat}. *)
val delete : string -> unit
(** Delete path *)
@ -102,23 +98,19 @@ module type VFS = sig
end
val vfs_of_dir : string -> (module VFS)
(** [vfs_of_dir dir] makes a virtual file system that reads from the
disk.
@since 0.12
*)
(** [vfs_of_dir dir] makes a virtual file system that reads from the disk.
@since 0.12 *)
val add_vfs :
config:config -> vfs:(module VFS) -> prefix:string -> Server.t -> unit
(** Similar to {!add_dir_path} but using a virtual file system instead.
@since 0.12
*)
@since 0.12 *)
(** An embedded file system, as a list of files with (relative) paths.
This is useful in combination with the "tiny-httpd-mkfs" tool,
which embeds the files it's given into a OCaml module.
(** An embedded file system, as a list of files with (relative) paths. This is
useful in combination with the "tiny-httpd-mkfs" tool, which embeds the
files it's given into a OCaml module.
@since 0.12
*)
@since 0.12 *)
module Embedded_fs : sig
type t
(** The pseudo-filesystem *)
@ -127,8 +119,9 @@ module Embedded_fs : sig
val add_file : ?mtime:float -> t -> path:string -> string -> unit
(** Add file to the virtual file system.
@raise Invalid_argument if the path contains '..' or if it tries to
make a directory out of an existing path that is a file. *)
@raise Invalid_argument
if the path contains '..' or if it tries to make a directory out of an
existing path that is a file. *)
val to_vfs : t -> (module VFS)
end

6
src/unix/tiny_httpd_unix.ml
View file

@ -43,9 +43,9 @@ module Unix_tcp_server_ = struct
| None ->
( Unix.socket
(if Util.is_ipv6_str self.addr then
Unix.PF_INET6
else
Unix.PF_INET)
Unix.PF_INET6
else
Unix.PF_INET)
Unix.SOCK_STREAM 0,
true (* Because we're creating the socket ourselves *) )
in

47
src/ws/dune
View file

@ -1,27 +1,50 @@
; Set BUILD_TINY_HTTPD_OPTLEVEL to the -O<num> level.
; Defaults to 2, which means -O2 is the default C optimization flag.
; Use -1 to remove the -O<num> flag entirely.
(rule
(enabled_if (>= %{env:BUILD_TINY_HTTPD_OPTLEVEL=2} 0))
(enabled_if
(>= %{env:BUILD_TINY_HTTPD_OPTLEVEL=2} 0))
(target optlevel.string)
(deps (env_var BUILD_TINY_HTTPD_OPTLEVEL))
(action (with-stdout-to %{target} (echo "-O%{env:BUILD_TINY_HTTPD_OPTLEVEL=2}"))))
(deps
(env_var BUILD_TINY_HTTPD_OPTLEVEL))
(action
(with-stdout-to
%{target}
(echo "-O%{env:BUILD_TINY_HTTPD_OPTLEVEL=2}"))))
(rule
(enabled_if (< %{env:BUILD_TINY_HTTPD_OPTLEVEL=2} 0))
(enabled_if
(< %{env:BUILD_TINY_HTTPD_OPTLEVEL=2} 0))
(target optlevel.string)
(deps (env_var BUILD_TINY_HTTPD_OPTLEVEL))
(action (with-stdout-to %{target} (echo ""))))
(deps
(env_var BUILD_TINY_HTTPD_OPTLEVEL))
(action
(with-stdout-to
%{target}
(echo ""))))
; All compilers will include the optimization level.
; Non-MSVC compilers will include `-std=c99 -fPIC`.
(rule
(enabled_if (= %{ocaml-config:ccomp_type} msvc))
(enabled_if
(= %{ocaml-config:ccomp_type} msvc))
(target cflags.sexp)
(action (with-stdout-to %{target} (echo "(%{read:optlevel.string})"))))
(action
(with-stdout-to
%{target}
(echo "(%{read:optlevel.string})"))))
(rule
(enabled_if (not (= %{ocaml-config:ccomp_type} msvc)))
(enabled_if
(not
(= %{ocaml-config:ccomp_type} msvc)))
(target cflags.sexp)
(action (with-stdout-to %{target} (echo "(-std=c99 -fPIC %{read:optlevel.string})"))))
(action
(with-stdout-to
%{target}
(echo "(-std=c99 -fPIC %{read:optlevel.string})"))))
(library
(name tiny_httpd_ws)
@ -32,7 +55,9 @@
(foreign_stubs
(language c)
(names tiny_httpd_ws_stubs)
(flags :standard (:include cflags.sexp)))
(flags
:standard
(:include cflags.sexp)))
(libraries
(re_export tiny_httpd.core)
threads))

9
src/ws/tiny_httpd_ws.ml
View file

@ -187,8 +187,8 @@ module Reader = struct
type state =
| Begin (** At the beginning of a frame *)
| Reading_frame of { mutable remaining_bytes: int; mutable num_read: int }
(** Currently reading the payload of a frame with [remaining_bytes]
left to read from the underlying [ic] *)
(** Currently reading the payload of a frame with [remaining_bytes] left
to read from the underlying [ic] *)
| Close
type t = {
@ -266,7 +266,7 @@ module Reader = struct
external apply_masking_ :
key:bytes -> key_offset:int -> buf:bytes -> int -> int -> unit
= "tiny_httpd_ws_apply_masking"
[@@noalloc]
[@@noalloc]
(** Apply masking to the parsed data *)
let[@inline] apply_masking ~mask_key ~mask_offset (buf : bytes) off len : unit
@ -414,7 +414,8 @@ let upgrade ic oc : _ * _ =
in
ws_ic, ws_oc
(** Turn a regular connection handler (provided by the user) into a websocket upgrade handler *)
(** Turn a regular connection handler (provided by the user) into a websocket
upgrade handler *)
module Make_upgrade_handler (X : sig
val accept_ws_protocol : string -> bool
val handler : handler

14
src/ws/tiny_httpd_ws.mli
View file

@ -1,8 +1,7 @@
(** Websockets for Tiny_httpd.
This sub-library ([tiny_httpd.ws]) exports a small implementation
for a websocket server. It has no additional dependencies.
*)
This sub-library ([tiny_httpd.ws]) exports a small implementation for a
websocket server. It has no additional dependencies. *)
type handler = unit Request.t -> IO.Input.t -> IO.Output.t -> unit
(** Websocket handler *)
@ -11,8 +10,8 @@ val upgrade : IO.Input.t -> IO.Output.t -> IO.Input.t * IO.Output.t
(** Upgrade a byte stream to the websocket framing protocol. *)
exception Close_connection
(** Exception that can be raised from IOs inside the handler,
when the connection is closed from underneath. *)
(** Exception that can be raised from IOs inside the handler, when the
connection is closed from underneath. *)
val add_route_handler :
?accept:(unit Request.t -> (unit, int * string) result) ->
@ -23,8 +22,9 @@ val add_route_handler :
handler ->
unit
(** Add a route handler for a websocket endpoint.
@param accept_ws_protocol decides whether this endpoint accepts the websocket protocol
sent by the client. Default accepts everything. *)
@param accept_ws_protocol
decides whether this endpoint accepts the websocket protocol sent by the
client. Default accepts everything. *)
(**/**)