diff --git a/.gitmodules b/.gitmodules
new file mode 100644
index 00000000..67cabbe6
--- /dev/null
+++ b/.gitmodules
@@ -0,0 +1,3 @@
+[submodule "vendor/iostream"]
+ path = vendor/iostream
+ url = https://github.com/c-cube/ocaml-iostream
diff --git a/dune-project b/dune-project
index 301047b7..370ef50a 100644
--- a/dune-project
+++ b/dune-project
@@ -21,6 +21,8 @@
seq
base-threads
result
+ hmap
+ (iostream (>= 0.2))
(ocaml (>= 4.08))
(odoc :with-doc)
(logs :with-test)
@@ -34,5 +36,6 @@
(depends
(tiny_httpd (= :version))
(camlzip (>= 1.06))
+ iostream-camlzip
(logs :with-test)
(odoc :with-doc)))
diff --git a/examples/echo.ml b/examples/echo.ml
index a8b1b232..f3d0f2af 100644
--- a/examples/echo.ml
+++ b/examples/echo.ml
@@ -1,4 +1,4 @@
-module S = Tiny_httpd
+open Tiny_httpd_core
module Log = Tiny_httpd.Log
let now_ = Unix.gettimeofday
@@ -34,7 +34,7 @@ let alice_text =
sides of the well, and noticed that they were filled with cupboards......"
(* util: a little middleware collecting statistics *)
-let middleware_stat () : S.Middleware.t * (unit -> string) =
+let middleware_stat () : Server.Middleware.t * (unit -> string) =
let n_req = ref 0 in
let total_time_ = ref 0. in
let parse_time_ = ref 0. in
@@ -43,7 +43,7 @@ let middleware_stat () : S.Middleware.t * (unit -> string) =
let m h req ~resp =
incr n_req;
- let t1 = S.Request.start_time req in
+ let t1 = Request.start_time req in
let t2 = now_ () in
h req ~resp:(fun response ->
let t3 = now_ () in
@@ -92,23 +92,23 @@ let () =
(fun _ -> raise (Arg.Bad ""))
"echo [option]*";
- let server = S.create ~port:!port_ ~max_connections:!j () in
+ let server = Tiny_httpd.create ~port:!port_ ~max_connections:!j () in
Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16 * 1024) server;
let m_stats, get_stats = middleware_stat () in
- S.add_middleware server ~stage:(`Stage 1) m_stats;
+ Server.add_middleware server ~stage:(`Stage 1) m_stats;
(* say hello *)
- S.add_route_handler ~meth:`GET server
- S.Route.(exact "hello" @/ string @/ return)
- (fun name _req -> S.Response.make_string (Ok ("hello " ^ name ^ "!\n")));
+ Server.add_route_handler ~meth:`GET server
+ Route.(exact "hello" @/ string @/ return)
+ (fun name _req -> Response.make_string (Ok ("hello " ^ name ^ "!\n")));
(* compressed file access *)
- S.add_route_handler ~meth:`GET server
- S.Route.(exact "zcat" @/ string_urlencoded @/ return)
+ Server.add_route_handler ~meth:`GET server
+ Route.(exact "zcat" @/ string_urlencoded @/ return)
(fun path _req ->
let ic = open_in path in
- let str = S.Byte_stream.of_chan ic in
+ let str = IO.Input.of_in_channel ic in
let mime_type =
try
let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" path) in
@@ -121,42 +121,42 @@ let () =
[]
with _ -> []
in
- S.Response.make_stream ~headers:mime_type (Ok str));
+ Response.make_stream ~headers:mime_type (Ok str));
(* echo request *)
- S.add_route_handler server
- S.Route.(exact "echo" @/ return)
+ Server.add_route_handler server
+ Route.(exact "echo" @/ return)
(fun req ->
let q =
- S.Request.query req
+ Request.query req
|> List.map (fun (k, v) -> Printf.sprintf "%S = %S" k v)
|> String.concat ";"
in
- S.Response.make_string
- (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." S.Request.pp req q)));
+ Response.make_string
+ (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." Request.pp req q)));
(* file upload *)
- S.add_route_handler_stream ~meth:`PUT server
- S.Route.(exact "upload" @/ string @/ return)
+ Server.add_route_handler_stream ~meth:`PUT server
+ Route.(exact "upload" @/ string @/ return)
(fun path req ->
Log.debug (fun k ->
k "start upload %S, headers:\n%s\n\n%!" path
- (Format.asprintf "%a" S.Headers.pp (S.Request.headers req)));
+ (Format.asprintf "%a" Headers.pp (Request.headers req)));
try
let oc = open_out @@ "/tmp/" ^ path in
- S.Byte_stream.to_chan oc req.S.Request.body;
+ IO.Input.to_chan oc req.Request.body;
flush oc;
- S.Response.make_string (Ok "uploaded file")
+ Response.make_string (Ok "uploaded file")
with e ->
- S.Response.fail ~code:500 "couldn't upload file: %s"
+ Response.fail ~code:500 "couldn't upload file: %s"
(Printexc.to_string e));
(* protected by login *)
- S.add_route_handler server
- S.Route.(exact "protected" @/ return)
+ Server.add_route_handler server
+ Route.(exact "protected" @/ return)
(fun req ->
let ok =
- match S.Request.get_header req "authorization" with
+ match Request.get_header req "authorization" with
| Some v ->
Log.debug (fun k -> k "authenticate with %S" v);
v = "Basic " ^ base64 "user:foobar"
@@ -167,40 +167,40 @@ let () =
let s =
"hello, this is super secret!
log out"
in
- S.Response.make_string (Ok s)
+ Response.make_string (Ok s)
) else (
let headers =
- S.Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"")
+ Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"")
in
- S.Response.fail ~code:401 ~headers "invalid"
+ Response.fail ~code:401 ~headers "invalid"
));
(* logout *)
- S.add_route_handler server
- S.Route.(exact "logout" @/ return)
- (fun _req -> S.Response.fail ~code:401 "logged out");
+ Server.add_route_handler server
+ Route.(exact "logout" @/ return)
+ (fun _req -> Response.fail ~code:401 "logged out");
(* stats *)
- S.add_route_handler server
- S.Route.(exact "stats" @/ return)
+ Server.add_route_handler server
+ Route.(exact "stats" @/ return)
(fun _req ->
let stats = get_stats () in
- S.Response.make_string @@ Ok stats);
+ Response.make_string @@ Ok stats);
- S.add_route_handler server
- S.Route.(exact "alice" @/ return)
- (fun _req -> S.Response.make_string (Ok alice_text));
+ Server.add_route_handler server
+ Route.(exact "alice" @/ return)
+ (fun _req -> Response.make_string (Ok alice_text));
(* VFS *)
- Tiny_httpd_dir.add_vfs server
+ Tiny_httpd.Dir.add_vfs server
~config:
- (Tiny_httpd_dir.config ~download:true
- ~dir_behavior:Tiny_httpd_dir.Index_or_lists ())
+ (Tiny_httpd.Dir.config ~download:true
+ ~dir_behavior:Tiny_httpd.Dir.Index_or_lists ())
~vfs:Vfs.vfs ~prefix:"vfs";
(* main page *)
- S.add_route_handler server
- S.Route.(return)
+ Server.add_route_handler server
+ Route.(return)
(fun _req ->
let open Tiny_httpd_html in
let h =
@@ -272,9 +272,10 @@ let () =
]
in
let s = to_string_top h in
- S.Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok s);
+ Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok s);
- Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
- match S.run server with
+ Printf.printf "listening on http://%s:%d\n%!" (Server.addr server)
+ (Server.port server);
+ match Server.run server with
| Ok () -> ()
| Error e -> raise e
diff --git a/examples/echo_ws.ml b/examples/echo_ws.ml
index 5a616d3f..f24cf283 100644
--- a/examples/echo_ws.ml
+++ b/examples/echo_ws.ml
@@ -1,6 +1,5 @@
module S = Tiny_httpd
-module Log = Tiny_httpd.Log
-module IO = Tiny_httpd_io
+open Tiny_httpd_core
let setup_logging ~debug () =
Logs.set_reporter @@ Logs.format_reporter ();
@@ -13,8 +12,7 @@ let setup_logging ~debug () =
let handle_ws _client_addr ic oc =
Log.info (fun k ->
- k "new client connection from %s"
- (Tiny_httpd_util.show_sockaddr _client_addr));
+ k "new client connection from %s" (Util.show_sockaddr _client_addr));
let (_ : Thread.t) =
Thread.create
@@ -58,7 +56,7 @@ let () =
let server = S.create ~port:!port_ ~max_connections:!j () in
Tiny_httpd_ws.add_route_handler server
- S.Route.(exact "echo" @/ return)
+ Route.(exact "echo" @/ return)
handle_ws;
Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
diff --git a/examples/sse_server.ml b/examples/sse_server.ml
index 650c05cd..c458026a 100644
--- a/examples/sse_server.ml
+++ b/examples/sse_server.ml
@@ -1,7 +1,6 @@
(* serves some streams of events *)
-module S = Tiny_httpd
-module Log = Tiny_httpd_log
+open Tiny_httpd_core
let port = ref 8080
@@ -14,7 +13,7 @@ let () =
])
(fun _ -> ())
"sse_clock [opt*]";
- let server = S.create ~port:!port () in
+ let server = Tiny_httpd.create ~port:!port () in
let extra_headers =
[
@@ -24,9 +23,9 @@ let () =
in
(* tick/tock goes the clock *)
- S.add_route_server_sent_handler server
- S.Route.(exact "clock" @/ return)
- (fun _req (module EV : S.SERVER_SENT_GENERATOR) ->
+ Server.add_route_server_sent_handler server
+ Route.(exact "clock" @/ return)
+ (fun _req (module EV : Server.SERVER_SENT_GENERATOR) ->
Log.debug (fun k -> k "new SSE connection");
EV.set_headers extra_headers;
let tick = ref true in
@@ -47,26 +46,26 @@ let () =
done);
(* just count *)
- S.add_route_server_sent_handler server
- S.Route.(exact "count" @/ return)
- (fun _req (module EV : S.SERVER_SENT_GENERATOR) ->
+ Server.add_route_server_sent_handler server
+ Route.(exact "count" @/ return)
+ (fun _req (module EV : Server.SERVER_SENT_GENERATOR) ->
let n = ref 0 in
while true do
EV.send_event ~data:(string_of_int !n) ();
incr n;
Unix.sleepf 0.1
done);
- S.add_route_server_sent_handler server
- S.Route.(exact "count" @/ int @/ return)
- (fun n _req (module EV : S.SERVER_SENT_GENERATOR) ->
+ Server.add_route_server_sent_handler server
+ Route.(exact "count" @/ int @/ return)
+ (fun n _req (module EV : Server.SERVER_SENT_GENERATOR) ->
for i = 0 to n do
EV.send_event ~data:(string_of_int i) ();
Unix.sleepf 0.1
done;
EV.close ());
- Printf.printf "listening on http://localhost:%d/\n%!" (S.port server);
- match S.run server with
+ Printf.printf "listening on http://localhost:%d/\n%!" (Server.port server);
+ match Server.run server with
| Ok () -> ()
| Error e ->
Printf.eprintf "error: %s\n%!" (Printexc.to_string e);
diff --git a/examples/writer.ml b/examples/writer.ml
index 9911ac3b..fed4eb60 100644
--- a/examples/writer.ml
+++ b/examples/writer.ml
@@ -1,7 +1,8 @@
module H = Tiny_httpd
+open Tiny_httpd_core
let serve_zeroes server : unit =
- H.add_route_handler server H.(Route.(exact "zeroes" @/ int @/ return))
+ Server.add_route_handler server Route.(exact "zeroes" @/ int @/ return)
@@ fun n _req ->
(* stream [n] zeroes *)
let write (oc : H.IO.Output.t) : unit =
@@ -11,7 +12,7 @@ let serve_zeroes server : unit =
done
in
let writer = H.IO.Writer.make ~write () in
- H.Response.make_writer @@ Ok writer
+ Response.make_writer @@ Ok writer
let serve_file server : unit =
H.add_route_handler server H.(Route.(exact "file" @/ string @/ return))
@@ -32,9 +33,9 @@ let serve_file server : unit =
in
let writer = H.IO.Writer.make ~write () in
- H.Response.make_writer @@ Ok writer
+ Response.make_writer @@ Ok writer
) else
- H.Response.fail ~code:404 "file not found"
+ Response.fail ~code:404 "file not found"
let () =
let port = ref 8085 in
@@ -43,7 +44,7 @@ let () =
Printf.printf "listen on http://localhost:%d/\n%!" !port;
serve_file server;
serve_zeroes server;
- H.add_route_handler server H.Route.return (fun _req ->
+ H.add_route_handler server Route.return (fun _req ->
let body =
H.Html.(
div []
@@ -58,5 +59,5 @@ let () =
])
|> H.Html.to_string_top
in
- H.Response.make_string @@ Ok body);
+ Response.make_string @@ Ok body);
H.run_exn server
diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml
index dfdd3b46..cbffe69b 100644
--- a/src/Tiny_httpd.ml
+++ b/src/Tiny_httpd.ml
@@ -1,9 +1,68 @@
-module Buf = Tiny_httpd_buf
-module Byte_stream = Tiny_httpd_stream
-include Tiny_httpd_server
-module Util = Tiny_httpd_util
-module Dir = Tiny_httpd_dir
+module Buf = Buf
module Html = Tiny_httpd_html
-module IO = Tiny_httpd_io
-module Pool = Tiny_httpd_pool
-module Log = Tiny_httpd_log
+module IO = Tiny_httpd_core.IO
+module Request = Tiny_httpd_core.Request
+module Response = Tiny_httpd_core.Response
+module Response_code = Tiny_httpd_core.Response_code
+module Route = Tiny_httpd_core.Route
+module Headers = Tiny_httpd_core.Headers
+module Meth = Tiny_httpd_core.Meth
+module Pool = Tiny_httpd_core.Pool
+module Log = Tiny_httpd_core.Log
+module Server = Tiny_httpd_core.Server
+module Util = Tiny_httpd_core.Util
+include Server
+module Dir = Tiny_httpd_unix.Dir
+
+module type VFS = Tiny_httpd_unix.Dir.VFS
+
+open struct
+ let get_max_connection_ ?(max_connections = 64) () : int =
+ let max_connections = max 4 max_connections in
+ max_connections
+
+ let clear_slice (slice : IO.Slice.t) =
+ Bytes.fill slice.bytes 0 (Bytes.length slice.bytes) '\x00';
+ slice.off <- 0;
+ slice.len <- 0
+end
+
+let create ?(masksigpipe = true) ?max_connections ?(timeout = 0.0) ?buf_size
+ ?(get_time_s = Unix.gettimeofday)
+ ?(new_thread = fun f -> ignore (Thread.create f () : Thread.t))
+ ?(addr = "127.0.0.1") ?(port = 8080) ?sock ?middlewares () : t =
+ let max_connections = get_max_connection_ ?max_connections () in
+ let server =
+ {
+ Tiny_httpd_unix.Unix_tcp_server_.addr;
+ new_thread;
+ buf_pool =
+ Pool.create ~clear:Buf.clear_and_zero
+ ~mk_item:(fun () -> Buf.create ?size:buf_size ())
+ ();
+ slice_pool =
+ Pool.create ~clear:clear_slice
+ ~mk_item:
+ (let buf_size = Option.value buf_size ~default:4096 in
+ fun () -> IO.Slice.create buf_size)
+ ();
+ running = true;
+ port;
+ sock;
+ max_connections;
+ sem_max_connections = Tiny_httpd_unix.Sem.create max_connections;
+ masksigpipe;
+ timeout;
+ }
+ in
+ let tcp_server_builder =
+ Tiny_httpd_unix.Unix_tcp_server_.to_tcp_server server
+ in
+ let module B = struct
+ let init_addr () = addr
+ let init_port () = port
+ let get_time_s = get_time_s
+ let tcp_server () = tcp_server_builder
+ end in
+ let backend = (module B : IO_BACKEND) in
+ Server.create_from ?buf_size ?middlewares ~backend ()
diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli
index b4cc6e89..2490646e 100644
--- a/src/Tiny_httpd.mli
+++ b/src/Tiny_httpd.mli
@@ -79,39 +79,94 @@ echo:
processing streams and parsing requests.
*)
-module Buf = Tiny_httpd_buf
-
-(** {2 Generic byte streams} *)
-
-module Byte_stream = Tiny_httpd_stream
+module Buf = Buf
(** {2 IO Abstraction} *)
-module IO = Tiny_httpd_io
+module IO = Tiny_httpd_core.IO
(** {2 Logging *)
-module Log = Tiny_httpd_log
-
-(** {2 Main Server Type} *)
-
-(** @inline *)
-include module type of struct
- include Tiny_httpd_server
-end
+module Log = Tiny_httpd_core.Log
(** {2 Utils} *)
-module Util = Tiny_httpd_util
+module Util = Tiny_httpd_core.Util
(** {2 Resource pool} *)
-module Pool = Tiny_httpd_pool
+module Pool = Tiny_httpd_core.Pool
(** {2 Static directory serving} *)
-module Dir = Tiny_httpd_dir
+module Dir = Tiny_httpd_unix.Dir
+
+module type VFS = Tiny_httpd_unix.Dir.VFS
+
+(** {2 HTML combinators} *)
module Html = Tiny_httpd_html
(** Alias to {!Tiny_httpd_html}
@since 0.12 *)
+
+(** {2 Main server types} *)
+
+module Request = Tiny_httpd_core.Request
+module Response = Tiny_httpd_core.Response
+module Response_code = Tiny_httpd_core.Response_code
+module Route = Tiny_httpd_core.Route
+module Headers = Tiny_httpd_core.Headers
+module Meth = Tiny_httpd_core.Meth
+module Server = Tiny_httpd_core.Server
+
+(** @inline *)
+include module type of struct
+ include Server
+end
+
+val create :
+ ?masksigpipe:bool ->
+ ?max_connections:int ->
+ ?timeout:float ->
+ ?buf_size:int ->
+ ?get_time_s:(unit -> float) ->
+ ?new_thread:((unit -> unit) -> unit) ->
+ ?addr:string ->
+ ?port:int ->
+ ?sock:Unix.file_descr ->
+ ?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
+ unit ->
+ t
+(** Create a new webserver using UNIX abstractions.
+
+ The server will not do anything until {!run} is called on it.
+ Before starting the server, one can use {!add_path_handler} and
+ {!set_top_handler} to specify how to handle incoming requests.
+
+ @param masksigpipe if true, block the signal {!Sys.sigpipe} which otherwise
+ tends to kill client threads when they try to write on broken sockets. Default: [true].
+
+ @param buf_size size for buffers (since 0.11)
+
+ @param new_thread a function used to spawn a new thread to handle a
+ new client connection. By default it is {!Thread.create} but one
+ could use a thread pool instead.
+ See for example {{: https://github.com/c-cube/tiny-httpd-moonpool-bench/blob/0dcbbffb4fe34ea4ad79d46343ad0cebb69ca69f/examples/t1.ml#L31}
+ this use of moonpool}.
+
+ @param middlewares see {!add_middleware} for more details.
+
+ @param max_connections maximum number of simultaneous connections.
+ @param timeout connection is closed if the socket does not do read or
+ write for the amount of second. Default: 0.0 which means no timeout.
+ timeout is not recommended when using proxy.
+ @param addr address (IPv4 or IPv6) to listen on. Default ["127.0.0.1"].
+ @param port to listen on. Default [8080].
+ @param sock an existing socket given to the server to listen on, e.g. by
+ systemd on Linux (or launchd on macOS). If passed in, this socket will be
+ used instead of the [addr] and [port]. If not passed in, those will be
+ used. This parameter exists since 0.10.
+
+ @param get_time_s obtain the current timestamp in seconds.
+ This parameter exists since 0.11.
+*)
diff --git a/src/Tiny_httpd_io.ml b/src/Tiny_httpd_io.ml
deleted file mode 100644
index 407f5108..00000000
--- a/src/Tiny_httpd_io.ml
+++ /dev/null
@@ -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
diff --git a/src/Tiny_httpd_server.ml b/src/Tiny_httpd_server.ml
deleted file mode 100644
index f023324c..00000000
--- a/src/Tiny_httpd_server.ml
+++ /dev/null
@@ -1,1338 +0,0 @@
-type buf = Tiny_httpd_buf.t
-type byte_stream = Tiny_httpd_stream.t
-
-module Buf = Tiny_httpd_buf
-module Byte_stream = Tiny_httpd_stream
-module IO = Tiny_httpd_io
-module Pool = Tiny_httpd_pool
-module Log = Tiny_httpd_log
-
-exception Bad_req of int * string
-
-let bad_reqf c fmt = Printf.ksprintf (fun s -> raise (Bad_req (c, s))) fmt
-
-module Response_code = struct
- type t = int
-
- let ok = 200
- let not_found = 404
-
- let descr = function
- | 100 -> "Continue"
- | 200 -> "OK"
- | 201 -> "Created"
- | 202 -> "Accepted"
- | 204 -> "No content"
- | 300 -> "Multiple choices"
- | 301 -> "Moved permanently"
- | 302 -> "Found"
- | 304 -> "Not Modified"
- | 400 -> "Bad request"
- | 401 -> "Unauthorized"
- | 403 -> "Forbidden"
- | 404 -> "Not found"
- | 405 -> "Method not allowed"
- | 408 -> "Request timeout"
- | 409 -> "Conflict"
- | 410 -> "Gone"
- | 411 -> "Length required"
- | 413 -> "Payload too large"
- | 417 -> "Expectation failed"
- | 500 -> "Internal server error"
- | 501 -> "Not implemented"
- | 503 -> "Service unavailable"
- | n -> "Unknown response code " ^ string_of_int n (* TODO *)
-
- let[@inline] is_success n = n >= 200 && n < 400
-end
-
-type resp_error = Response_code.t * string
-type 'a resp_result = ('a, resp_error) result
-
-let unwrap_resp_result = function
- | Ok x -> x
- | Error (c, s) -> raise (Bad_req (c, s))
-
-module Meth = struct
- type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
-
- let to_string = function
- | `GET -> "GET"
- | `PUT -> "PUT"
- | `HEAD -> "HEAD"
- | `POST -> "POST"
- | `DELETE -> "DELETE"
- | `OPTIONS -> "OPTIONS"
-
- let pp out s = Format.pp_print_string out (to_string s)
-
- let of_string = function
- | "GET" -> `GET
- | "PUT" -> `PUT
- | "POST" -> `POST
- | "HEAD" -> `HEAD
- | "DELETE" -> `DELETE
- | "OPTIONS" -> `OPTIONS
- | s -> bad_reqf 400 "unknown method %S" s
-end
-
-module Headers = struct
- type t = (string * string) list
-
- let empty = []
-
- let contains name headers =
- let name' = String.lowercase_ascii name in
- List.exists (fun (n, _) -> name' = n) headers
-
- let get_exn ?(f = fun x -> x) x h =
- let x' = String.lowercase_ascii x in
- List.assoc x' h |> f
-
- let get ?(f = fun x -> x) x h =
- try Some (get_exn ~f x h) with Not_found -> None
-
- let remove x h =
- let x' = String.lowercase_ascii x in
- List.filter (fun (k, _) -> k <> x') h
-
- let set x y h =
- let x' = String.lowercase_ascii x in
- (x', y) :: List.filter (fun (k, _) -> k <> x') h
-
- let pp out l =
- let pp_pair out (k, v) = Format.fprintf out "@[%s: %s@]" k v in
- Format.fprintf out "@[%a@]" (Format.pp_print_list pp_pair) l
-
- (* token = 1*tchar
- tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" / "_"
- / "`" / "|" / "~" / DIGIT / ALPHA ; any VCHAR, except delimiters
- Reference: https://datatracker.ietf.org/doc/html/rfc7230#section-3.2 *)
- let is_tchar = function
- | '0' .. '9'
- | 'a' .. 'z'
- | 'A' .. 'Z'
- | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' | '_'
- | '`' | '|' | '~' ->
- true
- | _ -> false
-
- let for_all pred s =
- try
- String.iter (fun c -> if not (pred c) then raise Exit) s;
- true
- with Exit -> false
-
- let parse_ ~buf (bs : byte_stream) : t =
- let rec loop acc =
- let line = Byte_stream.read_line ~buf bs in
- Log.debug (fun k -> k "parsed header line %S" line);
- if line = "\r" then
- acc
- else (
- let k, v =
- try
- let i = String.index line ':' in
- let k = String.sub line 0 i in
- if not (for_all is_tchar k) then
- invalid_arg (Printf.sprintf "Invalid header key: %S" k);
- let v =
- String.sub line (i + 1) (String.length line - i - 1)
- |> String.trim
- in
- k, v
- with _ -> bad_reqf 400 "invalid header line: %S" line
- in
- loop ((String.lowercase_ascii k, v) :: acc)
- )
- in
- loop []
-end
-
-module Request = struct
- type 'body t = {
- meth: Meth.t;
- host: string;
- client_addr: Unix.sockaddr;
- headers: Headers.t;
- http_version: int * int;
- path: string;
- path_components: string list;
- query: (string * string) list;
- body: 'body;
- start_time: float;
- }
-
- let headers self = self.headers
- let host self = self.host
- let client_addr self = self.client_addr
- let meth self = self.meth
- let path self = self.path
- let body self = self.body
- let start_time self = self.start_time
- let query self = self.query
- let get_header ?f self h = Headers.get ?f h self.headers
-
- let remove_header k self =
- { self with headers = Headers.remove k self.headers }
-
- let get_header_int self h =
- match get_header self h with
- | Some x -> (try Some (int_of_string x) with _ -> None)
- | None -> None
-
- let set_header k v self = { self with headers = Headers.set k v self.headers }
- let update_headers f self = { self with headers = f self.headers }
- let set_body b self = { self with body = b }
-
- (** Should we close the connection after this request? *)
- let close_after_req (self : _ t) : bool =
- match self.http_version with
- | 1, 1 -> get_header self "connection" = Some "close"
- | 1, 0 -> not (get_header self "connection" = Some "keep-alive")
- | _ -> false
-
- let pp_comp_ out comp =
- Format.fprintf out "[%s]"
- (String.concat ";" @@ List.map (Printf.sprintf "%S") comp)
-
- let pp_query out q =
- Format.fprintf out "[%s]"
- (String.concat ";"
- @@ List.map (fun (a, b) -> Printf.sprintf "%S,%S" a b) q)
-
- let pp_ out self : unit =
- Format.fprintf out
- "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ body=?;@ \
- path_components=%a;@ query=%a@]}"
- (Meth.to_string self.meth) self.host Headers.pp self.headers self.path
- pp_comp_ self.path_components pp_query self.query
-
- let pp out self : unit =
- Format.fprintf out
- "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ body=%S;@ \
- path_components=%a;@ query=%a@]}"
- (Meth.to_string self.meth) self.host Headers.pp self.headers self.path
- self.body pp_comp_ self.path_components pp_query self.query
-
- (* decode a "chunked" stream into a normal stream *)
- let read_stream_chunked_ ?buf (bs : byte_stream) : byte_stream =
- Log.debug (fun k -> k "body: start reading chunked stream...");
- Byte_stream.read_chunked ?buf ~fail:(fun s -> Bad_req (400, s)) bs
-
- let limit_body_size_ ~max_size (bs : byte_stream) : byte_stream =
- Log.debug (fun k -> k "limit size of body to max-size=%d" max_size);
- Byte_stream.limit_size_to ~max_size ~close_rec:false bs
- ~too_big:(fun size ->
- (* read too much *)
- bad_reqf 413
- "body size was supposed to be %d, but at least %d bytes received"
- max_size size)
-
- let limit_body_size ~max_size (req : byte_stream t) : byte_stream t =
- { req with body = limit_body_size_ ~max_size req.body }
-
- (* read exactly [size] bytes from the stream *)
- let read_exactly ~size (bs : byte_stream) : byte_stream =
- Log.debug (fun k -> k "body: must read exactly %d bytes" size);
- Byte_stream.read_exactly bs ~close_rec:false ~size ~too_short:(fun size ->
- bad_reqf 400 "body is too short by %d bytes" size)
-
- (* parse request, but not body (yet) *)
- let parse_req_start ~client_addr ~get_time_s ~buf (bs : byte_stream) :
- unit t option resp_result =
- try
- let line = Byte_stream.read_line ~buf bs in
- let start_time = get_time_s () in
- let meth, path, version =
- try
- let off = ref 0 in
- let meth = Tiny_httpd_parse_.word line off in
- let path = Tiny_httpd_parse_.word line off in
- let http_version = Tiny_httpd_parse_.word line off in
- let version =
- match http_version with
- | "HTTP/1.1" -> 1
- | "HTTP/1.0" -> 0
- | v -> invalid_arg (Printf.sprintf "unsupported HTTP version: %s" v)
- in
- meth, path, version
- with
- | Invalid_argument msg ->
- Log.error (fun k -> k "invalid request line: `%s`: %s" line msg);
- raise (Bad_req (400, "Invalid request line"))
- | _ ->
- Log.error (fun k -> k "invalid request line: `%s`" line);
- raise (Bad_req (400, "Invalid request line"))
- in
- let meth = Meth.of_string meth in
- Log.debug (fun k -> k "got meth: %s, path %S" (Meth.to_string meth) path);
- let headers = Headers.parse_ ~buf bs in
- let host =
- match Headers.get "Host" headers with
- | None -> bad_reqf 400 "No 'Host' header in request"
- | Some h -> h
- in
- let path_components, query = Tiny_httpd_util.split_query path in
- let path_components = Tiny_httpd_util.split_on_slash path_components in
- let query =
- match Tiny_httpd_util.(parse_query query) with
- | Ok l -> l
- | Error e -> bad_reqf 400 "invalid query: %s" e
- in
- let req =
- {
- meth;
- query;
- host;
- client_addr;
- path;
- path_components;
- headers;
- http_version = 1, version;
- body = ();
- start_time;
- }
- in
- Ok (Some req)
- with
- | End_of_file | Sys_error _ | Unix.Unix_error _ -> Ok None
- | Bad_req (c, s) -> Error (c, s)
- | e -> Error (400, Printexc.to_string e)
-
- (* parse body, given the headers.
- @param tr_stream a transformation of the input stream. *)
- let parse_body_ ~tr_stream ~buf (req : byte_stream t) :
- byte_stream t resp_result =
- try
- let size =
- match Headers.get_exn "Content-Length" req.headers |> int_of_string with
- | n -> n (* body of fixed size *)
- | exception Not_found -> 0
- | exception _ -> bad_reqf 400 "invalid content-length"
- in
- let body =
- match get_header ~f:String.trim req "Transfer-Encoding" with
- | None -> read_exactly ~size @@ tr_stream req.body
- | Some "chunked" ->
- let bs =
- read_stream_chunked_ ~buf
- @@ tr_stream req.body (* body sent by chunks *)
- in
- if size > 0 then
- limit_body_size_ ~max_size:size bs
- else
- bs
- | Some s -> bad_reqf 500 "cannot handle transfer encoding: %s" s
- in
- Ok { req with body }
- with
- | End_of_file -> Error (400, "unexpected end of file")
- | Bad_req (c, s) -> Error (c, s)
- | e -> Error (400, Printexc.to_string e)
-
- let read_body_full ?buf ?buf_size (self : byte_stream t) : string t =
- try
- let buf =
- match buf with
- | Some b -> b
- | None -> Buf.create ?size:buf_size ()
- in
- let body = Byte_stream.read_all ~buf self.body in
- { self with body }
- with
- | Bad_req _ as e -> raise e
- | e -> bad_reqf 500 "failed to read body: %s" (Printexc.to_string e)
-
- module Internal_ = struct
- let parse_req_start ?(buf = Buf.create ()) ~client_addr ~get_time_s bs =
- parse_req_start ~client_addr ~get_time_s ~buf bs |> unwrap_resp_result
-
- let parse_body ?(buf = Buf.create ()) req bs : _ t =
- parse_body_ ~tr_stream:(fun s -> s) ~buf { req with body = bs }
- |> unwrap_resp_result
- end
-end
-
-module Response = struct
- type body =
- [ `String of string
- | `Stream of byte_stream
- | `Writer of IO.Writer.t
- | `Void ]
-
- type t = { code: Response_code.t; headers: Headers.t; body: body }
-
- let set_body body self = { self with body }
- let set_headers headers self = { self with headers }
- let update_headers f self = { self with headers = f self.headers }
- let set_header k v self = { self with headers = Headers.set k v self.headers }
-
- let remove_header k self =
- { self with headers = Headers.remove k self.headers }
-
- let set_code code self = { self with code }
-
- let make_raw ?(headers = []) ~code body : t =
- (* add content length to response *)
- let headers =
- Headers.set "Content-Length" (string_of_int (String.length body)) headers
- in
- { code; headers; body = `String body }
-
- let make_raw_stream ?(headers = []) ~code body : t =
- let headers = Headers.set "Transfer-Encoding" "chunked" headers in
- { code; headers; body = `Stream body }
-
- let make_raw_writer ?(headers = []) ~code body : t =
- let headers = Headers.set "Transfer-Encoding" "chunked" headers in
- { code; headers; body = `Writer body }
-
- let make_void_force_ ?(headers = []) ~code () : t =
- { code; headers; body = `Void }
-
- let make_void ?(headers = []) ~code () : t =
- let is_ok = code < 200 || code = 204 || code = 304 in
- if is_ok then
- make_void_force_ ~headers ~code ()
- else
- make_raw ~headers ~code "" (* invalid to not have a body *)
-
- let make_string ?headers ?(code = 200) r =
- match r with
- | Ok body -> make_raw ?headers ~code body
- | Error (code, msg) -> make_raw ?headers ~code msg
-
- let make_stream ?headers ?(code = 200) r =
- match r with
- | Ok body -> make_raw_stream ?headers ~code body
- | Error (code, msg) -> make_raw ?headers ~code msg
-
- let make_writer ?headers ?(code = 200) r : t =
- match r with
- | Ok body -> make_raw_writer ?headers ~code body
- | Error (code, msg) -> make_raw ?headers ~code msg
-
- let make ?headers ?(code = 200) r : t =
- match r with
- | Ok (`String body) -> make_raw ?headers ~code body
- | Ok (`Stream body) -> make_raw_stream ?headers ~code body
- | Ok `Void -> make_void ?headers ~code ()
- | Ok (`Writer f) -> make_raw_writer ?headers ~code f
- | Error (code, msg) -> make_raw ?headers ~code msg
-
- let fail ?headers ~code fmt =
- Printf.ksprintf (fun msg -> make_raw ?headers ~code msg) fmt
-
- let fail_raise ~code fmt =
- Printf.ksprintf (fun msg -> raise (Bad_req (code, msg))) fmt
-
- let pp out self : unit =
- let pp_body out = function
- | `String s -> Format.fprintf out "%S" s
- | `Stream _ -> Format.pp_print_string out ""
- | `Writer _ -> Format.pp_print_string out ""
- | `Void -> ()
- in
- Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" self.code
- Headers.pp self.headers pp_body self.body
-
- let output_ ~buf (oc : IO.Output.t) (self : t) : unit =
- (* double indirection:
- - print into [buffer] using [bprintf]
- - transfer to [buf_] so we can output from there *)
- let tmp_buffer = Buffer.create 32 in
- Buf.clear buf;
-
- (* write start of reply *)
- Printf.bprintf tmp_buffer "HTTP/1.1 %d %s\r\n" self.code
- (Response_code.descr self.code);
- Buf.add_buffer buf tmp_buffer;
- Buffer.clear tmp_buffer;
-
- let body, is_chunked =
- match self.body with
- | `String s when String.length s > 1024 * 500 ->
- (* chunk-encode large bodies *)
- `Writer (IO.Writer.of_string s), true
- | `String _ as b -> b, false
- | `Stream _ as b -> b, true
- | `Writer _ as b -> b, true
- | `Void as b -> b, false
- in
- let headers =
- if is_chunked then
- self.headers
- |> Headers.set "transfer-encoding" "chunked"
- |> Headers.remove "content-length"
- else
- self.headers
- in
- let self = { self with headers; body } in
- Log.debug (fun k ->
- k "t[%d]: output response: %s"
- (Thread.id @@ Thread.self ())
- (Format.asprintf "%a" pp { self with body = `String "<...>" }));
-
- (* write headers, using [buf] to batch writes *)
- List.iter
- (fun (k, v) ->
- Printf.bprintf tmp_buffer "%s: %s\r\n" k v;
- Buf.add_buffer buf tmp_buffer;
- Buffer.clear tmp_buffer)
- headers;
-
- IO.Output.output_buf oc buf;
- IO.Output.output_string oc "\r\n";
- Buf.clear buf;
-
- (match body with
- | `String "" | `Void -> ()
- | `String s -> IO.Output.output_string oc s
- | `Writer w ->
- (* use buffer to chunk encode [w] *)
- let oc' = IO.Output.chunk_encoding ~buf ~close_rec:false oc in
- (try
- IO.Writer.write oc' w;
- IO.Output.close oc'
- with e ->
- let bt = Printexc.get_raw_backtrace () in
- IO.Output.close oc';
- IO.Output.flush oc;
- Printexc.raise_with_backtrace e bt)
- | `Stream str ->
- (match Byte_stream.output_chunked' ~buf oc str with
- | () ->
- Log.debug (fun k ->
- k "t[%d]: done outputing stream" (Thread.id @@ Thread.self ()));
- Byte_stream.close str
- | exception e ->
- let bt = Printexc.get_raw_backtrace () in
- Log.error (fun k ->
- k "t[%d]: outputing stream failed with %s"
- (Thread.id @@ Thread.self ())
- (Printexc.to_string e));
- Byte_stream.close str;
- IO.Output.flush oc;
- Printexc.raise_with_backtrace e bt));
- IO.Output.flush oc
-end
-
-(* semaphore, for limiting concurrency. *)
-module Sem_ = struct
- 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
-end
-
-module Route = struct
- type path = string list (* split on '/' *)
-
- type (_, _) comp =
- | Exact : string -> ('a, 'a) comp
- | Int : (int -> 'a, 'a) comp
- | String : (string -> 'a, 'a) comp
- | String_urlencoded : (string -> 'a, 'a) comp
-
- type (_, _) t =
- | Fire : ('b, 'b) t
- | Rest : { url_encoded: bool } -> (string -> 'b, 'b) t
- | Compose : ('a, 'b) comp * ('b, 'c) t -> ('a, 'c) t
-
- let return = Fire
- let rest_of_path = Rest { url_encoded = false }
- let rest_of_path_urlencoded = Rest { url_encoded = true }
- let ( @/ ) a b = Compose (a, b)
- let string = String
- let string_urlencoded = String_urlencoded
- let int = Int
- let exact (s : string) = Exact s
-
- let exact_path (s : string) tail =
- let rec fn = function
- | [] -> tail
- | "" :: ls -> fn ls
- | s :: ls -> exact s @/ fn ls
- in
- fn (String.split_on_char '/' s)
-
- let rec eval : type a b. path -> (a, b) t -> a -> b option =
- fun path route f ->
- match path, route with
- | [], Fire -> Some f
- | _, Fire -> None
- | _, Rest { url_encoded } ->
- let whole_path = String.concat "/" path in
- (match
- if url_encoded then (
- match Tiny_httpd_util.percent_decode whole_path with
- | Some s -> s
- | None -> raise_notrace Exit
- ) else
- whole_path
- with
- | whole_path -> Some (f whole_path)
- | exception Exit -> None)
- | c1 :: path', Compose (comp, route') ->
- (match comp with
- | Int ->
- (match int_of_string c1 with
- | i -> eval path' route' (f i)
- | exception _ -> None)
- | String -> eval path' route' (f c1)
- | String_urlencoded ->
- (match Tiny_httpd_util.percent_decode c1 with
- | None -> None
- | Some s -> eval path' route' (f s))
- | Exact s ->
- if s = c1 then
- eval path' route' f
- else
- None)
- | [], Compose (String, Fire) -> Some (f "") (* trailing *)
- | [], Compose (String_urlencoded, Fire) -> Some (f "") (* trailing *)
- | [], Compose _ -> None
-
- let bpf = Printf.bprintf
-
- let rec pp_ : type a b. Buffer.t -> (a, b) t -> unit =
- fun out -> function
- | Fire -> bpf out "/"
- | Rest { url_encoded } ->
- bpf out ""
- (if url_encoded then
- "_urlencoded"
- else
- "")
- | Compose (Exact s, tl) -> bpf out "%s/%a" s pp_ tl
- | Compose (Int, tl) -> bpf out "/%a" pp_ tl
- | Compose (String, tl) -> bpf out "/%a" pp_ tl
- | Compose (String_urlencoded, tl) -> bpf out "/%a" pp_ tl
-
- let to_string x =
- let b = Buffer.create 16 in
- pp_ b x;
- Buffer.contents b
-
- let pp out x = Format.pp_print_string out (to_string x)
-end
-
-module Middleware = struct
- type handler = byte_stream Request.t -> resp:(Response.t -> unit) -> unit
- type t = handler -> handler
-
- (** Apply a list of middlewares to [h] *)
- let apply_l (l : t list) (h : handler) : handler =
- List.fold_right (fun m h -> m h) l h
-
- let[@inline] nil : t = fun h -> h
-end
-
-(* a request handler. handles a single request. *)
-type cb_path_handler = IO.Output.t -> Middleware.handler
-
-module type SERVER_SENT_GENERATOR = sig
- val set_headers : Headers.t -> unit
-
- val send_event :
- ?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
-
- val close : unit -> unit
-end
-
-type server_sent_generator = (module SERVER_SENT_GENERATOR)
-
-(** Handler that upgrades to another protocol *)
-module type UPGRADE_HANDLER = sig
- type handshake_state
- (** Some specific state returned after handshake *)
-
- val name : string
- (** Name in the "upgrade" header *)
-
- val handshake : unit Request.t -> (Headers.t * handshake_state, string) result
- (** Perform the handshake and upgrade the connection. The returned
- code is [101] alongside these headers. *)
-
- val handle_connection :
- Unix.sockaddr -> handshake_state -> IO.Input.t -> IO.Output.t -> unit
- (** Take control of the connection and take it from there *)
-end
-
-type upgrade_handler = (module UPGRADE_HANDLER)
-
-exception Upgrade of unit Request.t * upgrade_handler
-
-module type IO_BACKEND = sig
- val init_addr : unit -> string
- val init_port : unit -> int
-
- val get_time_s : unit -> float
- (** obtain the current timestamp in seconds. *)
-
- val tcp_server : unit -> Tiny_httpd_io.TCP_server.builder
- (** Server that can listen on a port and handle clients. *)
-end
-
-type handler_result =
- | Handle of cb_path_handler
- | Fail of resp_error
- | Upgrade of upgrade_handler
-
-let unwrap_handler_result req = function
- | Handle x -> x
- | Fail (c, s) -> raise (Bad_req (c, s))
- | Upgrade up -> raise (Upgrade (req, up))
-
-type t = {
- backend: (module IO_BACKEND);
- mutable tcp_server: IO.TCP_server.t option;
- buf_size: int;
- mutable handler: byte_stream Request.t -> Response.t;
- (** toplevel handler, if any *)
- mutable middlewares: (int * Middleware.t) list; (** Global middlewares *)
- mutable middlewares_sorted: (int * Middleware.t) list lazy_t;
- (** sorted version of {!middlewares} *)
- mutable path_handlers: (unit Request.t -> handler_result option) list;
- (** path handlers *)
- 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) =
- match self.tcp_server with
- | None ->
- let (module B) = self.backend in
- B.init_addr ()
- | Some s -> fst @@ s.endpoint ()
-
-let port (self : t) =
- match self.tcp_server with
- | None ->
- let (module B) = self.backend in
- B.init_port ()
- | Some s -> snd @@ s.endpoint ()
-
-let active_connections (self : t) =
- match self.tcp_server with
- | None -> 0
- | Some s -> s.active_connections ()
-
-let add_middleware ~stage self m =
- let stage =
- match stage with
- | `Encoding -> 0
- | `Stage n when n < 1 -> invalid_arg "add_middleware: bad stage"
- | `Stage n -> n
- in
- self.middlewares <- (stage, m) :: self.middlewares;
- self.middlewares_sorted <-
- lazy
- (List.stable_sort (fun (s1, _) (s2, _) -> compare s1 s2) self.middlewares)
-
-let add_decode_request_cb self f =
- (* turn it into a middleware *)
- let m h req ~resp =
- (* see if [f] modifies the stream *)
- let req0 = { req with Request.body = () } in
- match f req0 with
- | None -> h req ~resp (* pass through *)
- | Some (req1, tr_stream) ->
- let req = { req1 with Request.body = tr_stream req.Request.body } in
- h req ~resp
- in
- add_middleware self ~stage:`Encoding m
-
-let add_encode_response_cb self f =
- let m h req ~resp =
- h req ~resp:(fun r ->
- let req0 = { req with Request.body = () } in
- (* now transform [r] if we want to *)
- match f req0 r with
- | None -> resp r
- | Some r' -> resp r')
- in
- add_middleware self ~stage:`Encoding m
-
-let set_top_handler self f = self.handler <- f
-
-(* route the given handler.
- @param tr_req wraps the actual concrete function returned by the route
- and makes it into a handler. *)
-let add_route_handler_ ?(accept = fun _req -> Ok ()) ?(middlewares = []) ?meth
- ~tr_req self (route : _ Route.t) f =
- let ph req : handler_result option =
- match meth with
- | Some m when m <> req.Request.meth -> None (* ignore *)
- | _ ->
- (match Route.eval req.Request.path_components route f with
- | Some handler ->
- (* we have a handler, do we accept the request based on its headers? *)
- (match accept req with
- | Ok () ->
- Some
- (Handle
- (fun oc ->
- Middleware.apply_l middlewares @@ fun req ~resp ->
- tr_req oc req ~resp handler))
- | Error err -> Some (Fail err))
- | None -> None (* path didn't match *))
- in
- self.path_handlers <- ph :: self.path_handlers
-
-let add_route_handler (type a) ?accept ?middlewares ?meth self
- (route : (a, _) Route.t) (f : _) : unit =
- let tr_req _oc req ~resp f =
- let req =
- Pool.with_resource self.buf_pool @@ fun buf ->
- Request.read_body_full ~buf req
- in
- resp (f req)
- in
- add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f
-
-let add_route_handler_stream ?accept ?middlewares ?meth self route f =
- let tr_req _oc req ~resp f = resp (f req) in
- add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f
-
-let[@inline] _opt_iter ~f o =
- match o with
- | None -> ()
- | Some x -> f x
-
-exception Exit_SSE
-
-let add_route_server_sent_handler ?accept self route f =
- let tr_req (oc : IO.Output.t) req ~resp f =
- let req =
- Pool.with_resource self.buf_pool @@ fun buf ->
- Request.read_body_full ~buf req
- in
- let headers =
- ref Headers.(empty |> set "content-type" "text/event-stream")
- in
-
- (* send response once *)
- let resp_sent = ref false in
- let send_response_idempotent_ () =
- if not !resp_sent then (
- resp_sent := true;
- (* send 200 response now *)
- let initial_resp =
- Response.make_void_force_ ~headers:!headers ~code:200 ()
- in
- resp initial_resp
- )
- in
-
- let[@inline] writef fmt =
- Printf.ksprintf (IO.Output.output_string oc) fmt
- in
-
- let send_event ?event ?id ?retry ~data () : unit =
- send_response_idempotent_ ();
- _opt_iter event ~f:(fun e -> writef "event: %s\n" e);
- _opt_iter id ~f:(fun e -> writef "id: %s\n" e);
- _opt_iter retry ~f:(fun e -> writef "retry: %s\n" e);
- let l = String.split_on_char '\n' data in
- List.iter (fun s -> writef "data: %s\n" s) l;
- IO.Output.output_string oc "\n";
- (* finish group *)
- IO.Output.flush oc
- in
- let module SSG = struct
- let set_headers h =
- if not !resp_sent then (
- headers := List.rev_append h !headers;
- send_response_idempotent_ ()
- )
-
- let send_event = send_event
- let close () = raise Exit_SSE
- end in
- (try f req (module SSG : SERVER_SENT_GENERATOR)
- with Exit_SSE -> IO.Output.close oc);
- Log.info (fun k -> k "closed SSE connection")
- in
- add_route_handler_ self ?accept ~meth:`GET route ~tr_req f
-
-let add_upgrade_handler ?(accept = fun _ -> Ok ()) (self : t) route f : unit =
- let ph req : handler_result option =
- if req.Request.meth <> `GET then
- None
- else (
- match accept req with
- | Ok () ->
- (match Route.eval req.Request.path_components route f with
- | Some up -> Some (Upgrade up)
- | None -> None (* path didn't match *))
- | Error err -> Some (Fail err)
- )
- in
- self.path_handlers <- ph :: self.path_handlers
-
-let get_max_connection_ ?(max_connections = 64) () : int =
- let max_connections = max 4 max_connections in
- max_connections
-
-let create_from ?(buf_size = 16 * 1_024) ?(middlewares = []) ~backend () : t =
- let handler _req = Response.fail ~code:404 "no top handler" in
- let self =
- {
- backend;
- tcp_server = None;
- handler;
- buf_size;
- path_handlers = [];
- middlewares = [];
- middlewares_sorted = lazy [];
- buf_pool =
- Pool.create ~clear:Buf.clear_and_zero
- ~mk_item:(fun () -> Buf.create ~size:buf_size ())
- ();
- }
- in
- List.iter (fun (stage, m) -> add_middleware self ~stage m) middlewares;
- self
-
-let is_ipv6_str addr : bool = String.contains addr ':'
-
-module Unix_tcp_server_ = struct
- type t = {
- addr: string;
- port: int;
- buf_pool: Buf.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 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 ())
- (Tiny_httpd_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.buf_pool @@ fun buf ->
- let closed = ref false in
- let oc =
- IO.Output.of_unix_fd ~close_noerr:true ~closed ~buf client_sock
- in
- let ic =
- IO.Input.of_unix_fd ~close_noerr:true ~closed 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 ())
- @@ Tiny_httpd_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
- "@[Handler: uncaught exception for client %s:@ \
- %s@ %s@]"
- (Tiny_httpd_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
-
-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 =
- {
- Unix_tcp_server_.addr;
- new_thread;
- buf_pool =
- Pool.create ~clear:Buf.clear_and_zero
- ~mk_item:(fun () -> Buf.create ?size:buf_size ())
- ();
- running = true;
- port;
- sock;
- max_connections;
- sem_max_connections = Sem_.create max_connections;
- masksigpipe;
- timeout;
- }
- in
- let tcp_server_builder = 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
- create_from ?buf_size ?middlewares ~backend ()
-
-let stop (self : t) =
- match self.tcp_server with
- | None -> ()
- | Some s -> s.stop ()
-
-let running (self : t) =
- match self.tcp_server with
- | None -> false
- | Some s -> s.running ()
-
-let find_map f l =
- let rec aux f = function
- | [] -> None
- | x :: l' ->
- (match f x with
- | Some _ as res -> res
- | None -> aux f l')
- in
- aux f l
-
-let string_as_list_contains_ (s : string) (sub : string) : bool =
- let fragments = String.split_on_char ',' s in
- List.exists (fun fragment -> String.trim fragment = sub) fragments
-
-(* handle client on [ic] and [oc] *)
-let client_handle_for (self : t) ~client_addr ic oc : unit =
- Pool.with_resource self.buf_pool @@ fun buf ->
- Pool.with_resource self.buf_pool @@ fun buf_res ->
- let is = Byte_stream.of_input ~buf_size:self.buf_size ic in
- let (module B) = self.backend in
-
- (* how to log the response to this query *)
- let log_response (req : _ Request.t) (resp : Response.t) =
- if not Log.dummy then (
- let msgf k =
- let elapsed = B.get_time_s () -. req.start_time in
- k
- ("response to=%s code=%d time=%.3fs path=%S" : _ format4)
- (Tiny_httpd_util.show_sockaddr client_addr)
- resp.code elapsed req.path
- in
- if Response_code.is_success resp.code then
- Log.info msgf
- else
- Log.error msgf
- )
- in
-
- let log_exn msg bt =
- Log.error (fun k ->
- k "error while processing response for %s msg=%s@.%s"
- (Tiny_httpd_util.show_sockaddr client_addr)
- msg
- (Printexc.raw_backtrace_to_string bt))
- in
-
- (* handle generic exception *)
- let handle_exn e bt : unit =
- let msg = Printexc.to_string e in
- let resp = Response.fail ~code:500 "server error: %s" msg in
- if not Log.dummy then log_exn msg bt;
- Response.output_ ~buf:buf_res oc resp
- in
-
- let handle_bad_req req e bt =
- let msg = Printexc.to_string e in
- let resp = Response.fail ~code:500 "server error: %s" msg in
- if not Log.dummy then (
- log_exn msg bt;
- log_response req resp
- );
- Response.output_ ~buf:buf_res oc resp
- in
-
- let handle_upgrade req (module UP : UPGRADE_HANDLER) : unit =
- Log.debug (fun k -> k "upgrade connection");
- try
- (* check headers *)
- (match Request.get_header req "connection" with
- | Some str when string_as_list_contains_ str "Upgrade" -> ()
- | _ -> bad_reqf 426 "connection header must contain 'Upgrade'");
- (match Request.get_header req "upgrade" with
- | Some u when u = UP.name -> ()
- | Some u -> bad_reqf 426 "expected upgrade to be '%s', got '%s'" UP.name u
- | None -> bad_reqf 426 "expected 'connection: upgrade' header");
-
- (* ok, this is the upgrade we expected *)
- match UP.handshake req with
- | Error msg ->
- (* fail the upgrade *)
- Log.error (fun k -> k "upgrade failed: %s" msg);
- let resp = Response.make_raw ~code:429 "upgrade required" in
- log_response req resp;
- Response.output_ ~buf:buf_res oc resp
- | Ok (headers, handshake_st) ->
- (* send the upgrade reply *)
- let headers =
- [ "connection", "upgrade"; "upgrade", UP.name ] @ headers
- in
- let resp = Response.make_string ~code:101 ~headers (Ok "") in
- log_response req resp;
- Response.output_ ~buf:buf_res oc resp;
-
- (* now, give the whole connection over to the upgraded connection.
- Make sure to give the leftovers from [is] as well, if any.
- There might not be any because the first message doesn't normally come
- directly in the same packet as the handshake, but still. *)
- let ic =
- if is.len > 0 then (
- Log.debug (fun k -> k "LEFTOVERS! %d B" is.len);
- IO.Input.append (IO.Input.of_slice is.bs is.off is.len) ic
- ) else
- ic
- in
-
- UP.handle_connection client_addr handshake_st ic oc
- with e ->
- let bt = Printexc.get_raw_backtrace () in
- handle_bad_req req e bt
- in
-
- let continue = ref true in
-
- let handle_one_req () =
- match
- Request.parse_req_start ~client_addr ~get_time_s:B.get_time_s ~buf is
- with
- | Ok None -> continue := false (* client is done *)
- | Error (c, s) ->
- (* connection error, close *)
- let res = Response.make_raw ~code:c s in
- (try Response.output_ ~buf:buf_res oc res with Sys_error _ -> ());
- continue := false
- | Ok (Some req) ->
- Log.debug (fun k ->
- k "t[%d]: parsed request: %s"
- (Thread.id @@ Thread.self ())
- (Format.asprintf "@[%a@]" Request.pp_ req));
-
- if Request.close_after_req req then continue := false;
-
- (try
- (* is there a handler for this path? *)
- let base_handler =
- match find_map (fun ph -> ph req) self.path_handlers with
- | Some f -> unwrap_handler_result req f
- | None -> fun _oc req ~resp -> resp (self.handler req)
- in
-
- (* handle expect/continue *)
- (match Request.get_header ~f:String.trim req "Expect" with
- | Some "100-continue" ->
- Log.debug (fun k -> k "send back: 100 CONTINUE");
- Response.output_ ~buf:buf_res oc (Response.make_raw ~code:100 "")
- | Some s -> bad_reqf 417 "unknown expectation %s" s
- | None -> ());
-
- (* apply middlewares *)
- let handler oc =
- List.fold_right
- (fun (_, m) h -> m h)
- (Lazy.force self.middlewares_sorted)
- (base_handler oc)
- in
-
- (* now actually read request's body into a stream *)
- let req =
- Request.parse_body_
- ~tr_stream:(fun s -> s)
- ~buf { req with body = is }
- |> unwrap_resp_result
- in
-
- (* how to reply *)
- let resp r =
- try
- if Headers.get "connection" r.Response.headers = Some "close" then
- continue := false;
- log_response req r;
- Response.output_ ~buf:buf_res oc r
- with Sys_error e ->
- Log.debug (fun k ->
- k "error when writing response: %s@.connection broken" e);
- continue := false
- in
-
- (* call handler *)
- try handler oc req ~resp
- with Sys_error e ->
- Log.debug (fun k ->
- k "error while handling request: %s@.connection broken" e);
- continue := false
- with
- | Sys_error e ->
- (* connection broken somehow *)
- Log.debug (fun k -> k "error: %s@. connection broken" e);
- continue := false
- | Bad_req (code, s) ->
- continue := false;
- let resp = Response.make_raw ~code s in
- log_response req resp;
- Response.output_ ~buf:buf_res oc resp
- | Upgrade _ as e -> raise e
- | e ->
- let bt = Printexc.get_raw_backtrace () in
- handle_bad_req req e bt)
- in
-
- try
- while !continue && running self do
- Log.debug (fun k ->
- k "t[%d]: read next request" (Thread.id @@ Thread.self ()));
- handle_one_req ()
- done
- with
- | Upgrade (req, up) ->
- (* upgrades take over the whole connection, we won't process
- any further request *)
- handle_upgrade req up
- | e ->
- let bt = Printexc.get_raw_backtrace () in
- handle_exn e bt
-
-let client_handler (self : t) : IO.TCP_server.conn_handler =
- { IO.TCP_server.handle = client_handle_for self }
-
-let is_ipv6 (self : t) =
- let (module B) = self.backend in
- is_ipv6_str (B.init_addr ())
-
-let run_exn ?(after_init = ignore) (self : t) : unit =
- let (module B) = self.backend in
- let server = B.tcp_server () in
- server.serve
- ~after_init:(fun tcp_server ->
- self.tcp_server <- Some tcp_server;
- after_init ())
- ~handle:(client_handler self) ()
-
-let run ?after_init self : _ result =
- try Ok (run_exn ?after_init self) with e -> Error e
diff --git a/src/Tiny_httpd_server.mli b/src/Tiny_httpd_server.mli
deleted file mode 100644
index c9ee0763..00000000
--- a/src/Tiny_httpd_server.mli
+++ /dev/null
@@ -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 *)
diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml
index 468f7e32..38f20820 100644
--- a/src/bin/http_of_dir.ml
+++ b/src/bin/http_of_dir.ml
@@ -1,6 +1,6 @@
module S = Tiny_httpd
-module U = Tiny_httpd_util
-module D = Tiny_httpd_dir
+module U = Tiny_httpd.Util
+module D = Tiny_httpd.Dir
module Pf = Printf
module Log = Tiny_httpd.Log
diff --git a/src/bin/vfs_pack.ml b/src/bin/vfs_pack.ml
index 8eacfeff..0b888ebc 100644
--- a/src/bin/vfs_pack.ml
+++ b/src/bin/vfs_pack.ml
@@ -33,12 +33,12 @@ let is_url s =
is_prefix "http://" s || is_prefix "https://" s
let emit oc (l : entry list) : unit =
- fpf oc "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:%f ()\n"
+ fpf oc "let embedded_fs = Tiny_httpd.Dir.Embedded_fs.create ~mtime:%f ()\n"
now_;
let add_vfs ~mtime vfs_path content =
fpf oc
- "let () = Tiny_httpd_dir.Embedded_fs.add_file embedded_fs \n\
+ "let () = Tiny_httpd.Dir.Embedded_fs.add_file embedded_fs \n\
\ ~mtime:%h ~path:%S\n\
\ %S\n"
mtime vfs_path content
@@ -99,7 +99,7 @@ let emit oc (l : entry list) : unit =
in
List.iter add_entry l;
- fpf oc "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs\n";
+ fpf oc "let vfs = Tiny_httpd.Dir.Embedded_fs.to_vfs embedded_fs\n";
()
let help =
diff --git a/src/camlzip/Tiny_httpd_camlzip.ml b/src/camlzip/Tiny_httpd_camlzip.ml
index 7d390211..4e8f5172 100644
--- a/src/camlzip/Tiny_httpd_camlzip.ml
+++ b/src/camlzip/Tiny_httpd_camlzip.ml
@@ -1,175 +1,59 @@
-module S = Tiny_httpd_server
-module BS = Tiny_httpd_stream
-module W = Tiny_httpd_io.Writer
-module Out = Tiny_httpd_io.Output
-module Log = Tiny_httpd.Log
+module W = IO.Writer
-let decode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream =
+(* TODO: just use iostream-camlzip? *)
+
+let decode_deflate_stream_ ~buf_size (ic : IO.Input.t) : IO.Input.t =
Log.debug (fun k -> k "wrap stream with deflate.decode");
- let zlib_str = Zlib.inflate_init false in
- let is_done = ref false in
- BS.make ~bs:(Bytes.create buf_size)
- ~close:(fun _ ->
- Zlib.inflate_end zlib_str;
- BS.close is)
- ~consume:(fun self len ->
- if len > self.len then
- S.Response.fail_raise ~code:400
- "inflate: error during decompression: invalid consume len %d (max %d)"
- len self.len;
- self.off <- self.off + len;
- self.len <- self.len - len)
- ~fill:(fun self ->
- (* refill [buf] if needed *)
- if self.len = 0 && not !is_done then (
- is.fill_buf ();
- (try
- let finished, used_in, used_out =
- Zlib.inflate zlib_str self.bs 0 (Bytes.length self.bs) is.bs is.off
- is.len Zlib.Z_SYNC_FLUSH
- in
- is.consume used_in;
- self.off <- 0;
- self.len <- used_out;
- if finished then is_done := true;
- Log.debug (fun k ->
- k "decode %d bytes as %d bytes from inflate (finished: %b)"
- used_in used_out finished)
- with Zlib.Error (e1, e2) ->
- S.Response.fail_raise ~code:400
- "inflate: error during decompression:\n%s %s" e1 e2);
- Log.debug (fun k ->
- k "inflate: refill %d bytes into internal buf" self.len)
- ))
- ()
+ Iostream_camlzip.decompress_in_buf ~buf_size ic
let encode_deflate_writer_ ~buf_size (w : W.t) : W.t =
Log.debug (fun k -> k "wrap writer with deflate.encode");
- let zlib_str = Zlib.deflate_init 4 false in
- let o_buf = Bytes.create buf_size in
- let o_off = ref 0 in
- let o_len = ref 0 in
-
- (* write output buffer to out *)
- let write_out (oc : Out.t) =
- if !o_len > 0 then (
- Out.output oc o_buf !o_off !o_len;
- o_off := 0;
- o_len := 0
- )
+ let { IO.Writer.write } = w in
+ let write' (oc : IO.Output.t) =
+ let oc' = Iostream_camlzip.compressed_out ~buf_size ~level:4 oc in
+ write (oc' :> IO.Output.t)
in
+ IO.Writer.make ~write:write' ()
- let flush_zlib ~flush (oc : Out.t) =
- let continue = ref true in
- while !continue do
- let finished, used_in, used_out =
- Zlib.deflate zlib_str Bytes.empty 0 0 o_buf 0 (Bytes.length o_buf) flush
- in
- assert (used_in = 0);
- o_len := !o_len + used_out;
- if finished then continue := false;
- write_out oc
- done
- in
-
- (* compress and consume input buffer *)
- let write_zlib ~flush (oc : Out.t) buf i len =
- let i = ref i in
- let len = ref len in
- while !len > 0 do
- let _finished, used_in, used_out =
- Zlib.deflate zlib_str buf !i !len o_buf 0 (Bytes.length o_buf) flush
- in
- i := !i + used_in;
- len := !len - used_in;
- o_len := !o_len + used_out;
- write_out oc
- done
- in
-
- let write (oc : Out.t) : unit =
- let output buf i len = write_zlib ~flush:Zlib.Z_NO_FLUSH oc buf i len in
-
- let bchar = Bytes.create 1 in
- let output_char c =
- Bytes.set bchar 0 c;
- output bchar 0 1
- in
-
- let flush () =
- flush_zlib oc ~flush:Zlib.Z_FINISH;
- assert (!o_len = 0);
- oc.flush ()
- in
- let close () =
- flush ();
- Zlib.deflate_end zlib_str;
- oc.close ()
- in
- (* new output channel that compresses on the fly *)
- let oc' = { Out.flush; close; output; output_char } in
- w.write oc';
- oc'.close ()
- in
-
- W.make ~write ()
-
-let split_on_char ?(f = fun x -> x) c s : string list =
- let rec loop acc i =
- match String.index_from s i c with
- | exception Not_found ->
- let acc =
- if i = String.length s then
- acc
- else
- f (String.sub s i (String.length s - i)) :: acc
- in
- List.rev acc
- | j ->
- let acc = f (String.sub s i (j - i)) :: acc in
- loop acc (j + 1)
- in
- loop [] 0
-
-let accept_deflate (req : _ S.Request.t) =
- match S.Request.get_header req "Accept-Encoding" with
- | Some s -> List.mem "deflate" @@ split_on_char ~f:String.trim ',' s
+let accept_deflate (req : _ Request.t) =
+ match Request.get_header req "Accept-Encoding" with
+ | Some s ->
+ List.mem "deflate" @@ List.rev_map String.trim @@ String.split_on_char ',' s
| None -> false
let has_deflate s =
try Scanf.sscanf s "deflate, %s" (fun _ -> true) with _ -> false
(* decompress [req]'s body if needed *)
-let decompress_req_stream_ ~buf_size (req : BS.t S.Request.t) : _ S.Request.t =
- match S.Request.get_header ~f:String.trim req "Transfer-Encoding" with
+let decompress_req_stream_ ~buf_size (req : IO.Input.t Request.t) : _ Request.t
+ =
+ match Request.get_header ~f:String.trim req "Transfer-Encoding" with
(* TODO
| Some "gzip" ->
let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in
Some (req', decode_gzip_stream_)
*)
| Some "deflate" ->
- let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in
- req
- |> S.Request.remove_header "Transfer-Encoding"
- |> S.Request.set_body body'
+ let body' = Request.body req |> decode_deflate_stream_ ~buf_size in
+ req |> Request.remove_header "Transfer-Encoding" |> Request.set_body body'
| Some s when has_deflate s ->
(match Scanf.sscanf s "deflate, %s" (fun s -> s) with
| tr' ->
- let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in
+ let body' = Request.body req |> decode_deflate_stream_ ~buf_size in
req
- |> S.Request.set_header "Transfer-Encoding" tr'
- |> S.Request.set_body body'
+ |> Request.set_header "Transfer-Encoding" tr'
+ |> Request.set_body body'
| exception _ -> req)
| _ -> req
-let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t)
- (resp : S.Response.t) : S.Response.t =
+let compress_resp_stream_ ~compress_above ~buf_size (req : _ Request.t)
+ (resp : Response.t) : Response.t =
(* headers for compressed stream *)
let update_headers h =
h
- |> S.Headers.remove "Content-Length"
- |> S.Headers.set "Content-Encoding" "deflate"
+ |> Headers.remove "Content-Length"
+ |> Headers.set "Content-Encoding" "deflate"
in
if accept_deflate req then (
@@ -181,25 +65,25 @@ let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t)
(String.length s) compress_above);
let body = encode_deflate_writer_ ~buf_size @@ W.of_string s in
resp
- |> S.Response.update_headers update_headers
- |> S.Response.set_body (`Writer body)
- | `Stream str ->
+ |> Response.update_headers update_headers
+ |> Response.set_body (`Writer body)
+ | `Stream ic ->
Log.debug (fun k -> k "encode stream response with deflate");
- let w = BS.to_writer str in
+ let w = IO.Writer.of_input ic in
resp
- |> S.Response.update_headers update_headers
- |> S.Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
+ |> Response.update_headers update_headers
+ |> Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
| `Writer w ->
Log.debug (fun k -> k "encode writer response with deflate");
resp
- |> S.Response.update_headers update_headers
- |> S.Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
+ |> Response.update_headers update_headers
+ |> Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
| `String _ | `Void -> resp
) else
resp
let middleware ?(compress_above = 16 * 1024) ?(buf_size = 16 * 1_024) () :
- S.Middleware.t =
+ Server.Middleware.t =
let buf_size = max buf_size 1_024 in
fun h req ~resp ->
let req = decompress_req_stream_ ~buf_size req in
@@ -209,4 +93,4 @@ let middleware ?(compress_above = 16 * 1024) ?(buf_size = 16 * 1_024) () :
let setup ?compress_above ?buf_size server =
let m = middleware ?compress_above ?buf_size () in
Log.info (fun k -> k "setup gzip middleware");
- S.add_middleware ~stage:`Encoding server m
+ Server.add_middleware ~stage:`Encoding server m
diff --git a/src/camlzip/Tiny_httpd_camlzip.mli b/src/camlzip/Tiny_httpd_camlzip.mli
index 2fb7f570..f098e6da 100644
--- a/src/camlzip/Tiny_httpd_camlzip.mli
+++ b/src/camlzip/Tiny_httpd_camlzip.mli
@@ -7,7 +7,7 @@
*)
val middleware :
- ?compress_above:int -> ?buf_size:int -> unit -> Tiny_httpd_server.Middleware.t
+ ?compress_above:int -> ?buf_size:int -> unit -> Server.Middleware.t
(** Middleware responsible for deflate compression/decompression.
@param compress_above threshold, in bytes, above which a response body
that has a known content-length is compressed. Stream bodies
@@ -15,7 +15,7 @@ val middleware :
@param buf_size size of the underlying buffer for compression/decompression
@since 0.11 *)
-val setup : ?compress_above:int -> ?buf_size:int -> Tiny_httpd_server.t -> unit
+val setup : ?compress_above:int -> ?buf_size:int -> Server.t -> unit
(** Install middleware for tiny_httpd to be able to encode/decode
compressed streams
@param compress_above threshold above with string responses are compressed
diff --git a/src/camlzip/dune b/src/camlzip/dune
index 6ffc109f..d7192304 100644
--- a/src/camlzip/dune
+++ b/src/camlzip/dune
@@ -2,5 +2,5 @@
(name tiny_httpd_camlzip)
(public_name tiny_httpd_camlzip)
(synopsis "A wrapper around camlzip to bring compression to Tiny_httpd")
- (flags :standard -safe-string -warn-error -a+8)
- (libraries tiny_httpd camlzip))
+ (flags :standard -open Tiny_httpd_core -safe-string -warn-error -a+8)
+ (libraries tiny_httpd.core iostream-camlzip camlzip))
diff --git a/src/core/IO.ml b/src/core/IO.ml
new file mode 100644
index 00000000..249da955
--- /dev/null
+++ b/src/core/IO.ml
@@ -0,0 +1,478 @@
+(** IO abstraction.
+
+ We abstract IO so we can support classic unix blocking IOs
+ with threads, and modern async IO with Eio.
+
+ {b NOTE}: experimental.
+
+ @since 0.14
+*)
+
+open Common_
+module Buf = Buf
+module Slice = Iostream.Slice
+
+(** Output channel (byte sink) *)
+module Output = struct
+ include Iostream.Out_buf
+
+ class of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
+ (fd : Unix.file_descr) : t =
+ object
+ inherit t_from_output ~bytes:buf.bytes ()
+
+ method private output_underlying bs i len0 =
+ let i = ref i in
+ let len = ref len0 in
+ while !len > 0 do
+ match Unix.write fd bs !i !len with
+ | 0 -> failwith "write failed"
+ | n ->
+ i := !i + n;
+ len := !len - n
+ | exception
+ Unix.Unix_error
+ ( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
+ | Unix.ECONNRESET | Unix.EPIPE ),
+ _,
+ _ ) ->
+ failwith "write failed"
+ | exception
+ Unix.Unix_error
+ ((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
+ ignore (Unix.select [] [ fd ] [] 1.)
+ done
+
+ method private close_underlying () =
+ if not !closed then (
+ closed := true;
+ if close_noerr then (
+ try Unix.close fd with _ -> ()
+ ) else
+ Unix.close fd
+ )
+ end
+
+ let output_buf (self : t) (buf : Buf.t) : unit =
+ let b = Buf.bytes_slice buf in
+ output self b 0 (Buf.size buf)
+
+ (** [chunk_encoding oc] makes a new channel that outputs its content into [oc]
+ in chunk encoding form.
+ @param close_rec if true, closing the result will also close [oc]
+ @param buf a buffer used to accumulate data into chunks.
+ Chunks are emitted when [buf]'s size gets over a certain threshold,
+ or when [flush] is called.
+ *)
+ let chunk_encoding ?(buf = Buf.create ()) ~close_rec (oc : #t) : t =
+ (* write content of [buf] as a chunk if it's big enough.
+ If [force=true] then write content of [buf] if it's simply non empty. *)
+ let write_buf ~force () =
+ let n = Buf.size buf in
+ if (force && n > 0) || n >= 4_096 then (
+ output_string oc (Printf.sprintf "%x\r\n" n);
+ output oc (Buf.bytes_slice buf) 0 n;
+ output_string oc "\r\n";
+ Buf.clear buf
+ )
+ in
+
+ object
+ method flush () =
+ write_buf ~force:true ();
+ flush oc
+
+ method close () =
+ write_buf ~force:true ();
+ (* write an empty chunk to close the stream *)
+ output_string oc "0\r\n";
+ (* write another crlf after the stream (see #56) *)
+ output_string oc "\r\n";
+ flush oc;
+ if close_rec then close oc
+
+ method output b i n =
+ Buf.add_bytes buf b i n;
+ write_buf ~force:false ()
+
+ method output_char c =
+ Buf.add_char buf c;
+ write_buf ~force:false ()
+ end
+end
+
+(** Input channel (byte source) *)
+module Input = struct
+ include Iostream.In_buf
+
+ let of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
+ (fd : Unix.file_descr) : t =
+ let eof = ref false in
+ object
+ inherit Iostream.In_buf.t_from_refill ~bytes:buf.bytes ()
+
+ method private refill (slice : Slice.t) =
+ if not !eof then (
+ slice.off <- 0;
+ let continue = ref true in
+ while !continue do
+ match Unix.read fd slice.bytes 0 (Bytes.length slice.bytes) with
+ | n ->
+ slice.len <- n;
+ continue := false
+ | exception
+ Unix.Unix_error
+ ( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
+ | Unix.ECONNRESET | Unix.EPIPE ),
+ _,
+ _ ) ->
+ eof := true;
+ continue := false
+ | exception
+ Unix.Unix_error
+ ((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
+ ignore (Unix.select [ fd ] [] [] 1.)
+ done;
+ (* Printf.eprintf "read returned %d B\n%!" !n; *)
+ if slice.len = 0 then eof := true
+ )
+
+ method close () =
+ if not !closed then (
+ closed := true;
+ eof := true;
+ if close_noerr then (
+ try Unix.close fd with _ -> ()
+ ) else
+ Unix.close fd
+ )
+ end
+
+ let of_slice (slice : Slice.t) : t =
+ object
+ inherit Iostream.In_buf.t_from_refill ~bytes:slice.bytes ()
+
+ method private refill (slice : Slice.t) =
+ slice.off <- 0;
+ slice.len <- 0
+
+ method close () = ()
+ end
+
+ (** Read into the given slice.
+ @return the number of bytes read, [0] means end of input. *)
+ let[@inline] input (self : t) buf i len = self#input buf i len
+
+ (** Close the channel. *)
+ let[@inline] close self : unit = self#close ()
+
+ (** Read exactly [len] bytes.
+ @raise End_of_file if the input did not contain enough data. *)
+ let really_input (self : t) buf i len : unit =
+ let i = ref i in
+ let len = ref len in
+ while !len > 0 do
+ let n = input self buf !i !len in
+ if n = 0 then raise End_of_file;
+ i := !i + n;
+ len := !len - n
+ done
+
+ let append (i1 : #t) (i2 : #t) : t =
+ let use_i1 = ref true in
+ let rec input_rec (slice : Slice.t) =
+ if !use_i1 then (
+ slice.len <- input i1 slice.bytes 0 (Bytes.length slice.bytes);
+ if slice.len = 0 then (
+ use_i1 := false;
+ input_rec slice
+ )
+ ) else
+ slice.len <- input i1 slice.bytes 0 (Bytes.length slice.bytes)
+ in
+
+ object
+ inherit Iostream.In_buf.t_from_refill ()
+
+ method private refill (slice : Slice.t) =
+ slice.off <- 0;
+ input_rec slice
+
+ method close () =
+ close i1;
+ close i2
+ end
+
+ let iter_slice (f : Slice.t -> unit) (self : #t) : unit =
+ let continue = ref true in
+ while !continue do
+ let slice = self#fill_buf () in
+ if slice.len = 0 then (
+ continue := false;
+ close self
+ ) else (
+ f slice;
+ Slice.consume slice slice.len
+ )
+ done
+
+ let iter f self =
+ iter_slice (fun (slice : Slice.t) -> f slice.bytes slice.off slice.len) self
+
+ let to_chan oc (self : #t) =
+ iter_slice
+ (fun (slice : Slice.t) ->
+ Stdlib.output oc slice.bytes slice.off slice.len)
+ self
+
+ let to_chan' (oc : #Iostream.Out.t) (self : #t) : unit =
+ iter_slice
+ (fun (slice : Slice.t) ->
+ Iostream.Out.output oc slice.bytes slice.off slice.len)
+ self
+
+ let read_all_using ~buf (self : #t) : string =
+ Buf.clear buf;
+ let continue = ref true in
+ while !continue do
+ let slice = fill_buf self in
+ if slice.len = 0 then
+ continue := false
+ else (
+ assert (slice.len > 0);
+ Buf.add_bytes buf slice.bytes slice.off slice.len;
+ Slice.consume slice slice.len
+ )
+ done;
+ Buf.contents_and_clear buf
+
+ (** Read [n] bytes from the input into [bytes]. *)
+ let read_exactly_ ~too_short (self : #t) (bytes : bytes) (n : int) : unit =
+ assert (Bytes.length bytes >= n);
+ let offset = ref 0 in
+ while !offset < n do
+ let slice = self#fill_buf () in
+ let n_read = min slice.len (n - !offset) in
+ Bytes.blit slice.bytes slice.off bytes !offset n_read;
+ offset := !offset + n_read;
+ Slice.consume slice n_read;
+ if n_read = 0 then too_short ()
+ done
+
+ (** read a line into the buffer, after clearing it. *)
+ let read_line_into (self : t) ~buf : unit =
+ Buf.clear buf;
+ let continue = ref true in
+ while !continue do
+ let slice = self#fill_buf () in
+ if slice.len = 0 then (
+ continue := false;
+ if Buf.size buf = 0 then raise End_of_file
+ );
+ let j = ref slice.off in
+ while !j < slice.off + slice.len && Bytes.get slice.bytes !j <> '\n' do
+ incr j
+ done;
+ if !j - slice.off < slice.len then (
+ assert (Bytes.get slice.bytes !j = '\n');
+ (* line without '\n' *)
+ Buf.add_bytes buf slice.bytes slice.off (!j - slice.off);
+ (* consume line + '\n' *)
+ Slice.consume slice (!j - slice.off + 1);
+ continue := false
+ ) else (
+ Buf.add_bytes buf slice.bytes slice.off slice.len;
+ Slice.consume slice slice.len
+ )
+ done
+
+ let read_line_using ~buf (self : #t) : string =
+ read_line_into self ~buf;
+ Buf.contents_and_clear buf
+
+ let read_line_using_opt ~buf (self : #t) : string option =
+ match read_line_into self ~buf with
+ | () -> Some (Buf.contents_and_clear buf)
+ | exception End_of_file -> None
+
+ (* helper for making a new input stream that either contains at most [size]
+ bytes, or contains exactly [size] bytes. *)
+ let reading_exactly_ ~skip_on_close ~close_rec ~size ~bytes (arg : t) : t =
+ let remaining_size = ref size in
+
+ object
+ inherit t_from_refill ~bytes ()
+
+ method close () =
+ if !remaining_size > 0 && skip_on_close then skip arg !remaining_size;
+ if close_rec then close arg
+
+ method private refill (slice : Slice.t) =
+ slice.off <- 0;
+ slice.len <- 0;
+ if !remaining_size > 0 then (
+ let sub = fill_buf arg in
+ let n =
+ min !remaining_size (min sub.len (Bytes.length slice.bytes))
+ in
+ Bytes.blit sub.bytes sub.off slice.bytes 0 n;
+ Slice.consume sub n;
+ remaining_size := !remaining_size - n;
+ slice.len <- n
+ )
+ end
+
+ (** new stream with maximum size [max_size].
+ @param close_rec if true, closing this will also close the input stream *)
+ let limit_size_to ~close_rec ~max_size ~bytes (arg : t) : t =
+ reading_exactly_ ~size:max_size ~skip_on_close:false ~bytes ~close_rec arg
+
+ (** New stream that consumes exactly [size] bytes from the input.
+ If fewer bytes are read before [close] is called, we read and discard
+ the remaining quota of bytes before [close] returns.
+ @param close_rec if true, closing this will also close the input stream *)
+ let reading_exactly ~close_rec ~size ~bytes (arg : t) : t =
+ reading_exactly_ ~size ~close_rec ~skip_on_close:true ~bytes arg
+
+ let read_chunked ~(bytes : bytes) ~fail (ic : #t) : t =
+ let first = ref true in
+
+ (* small buffer to read the chunk sizes *)
+ let line_buf = Buf.create ~size:32 () in
+ let read_next_chunk_len () : int =
+ if !first then
+ first := false
+ else (
+ let line = read_line_using ~buf:line_buf ic in
+ if String.trim line <> "" then
+ raise (fail "expected crlf between chunks")
+ );
+ let line = read_line_using ~buf:line_buf ic in
+ (* parse chunk length, ignore extensions *)
+ let chunk_size =
+ if String.trim line = "" then
+ 0
+ else (
+ try
+ let off = ref 0 in
+ let n = Parse_.pos_hex line off in
+ n
+ with _ ->
+ raise (fail (spf "cannot read chunk size from line %S" line))
+ )
+ in
+ chunk_size
+ in
+ let eof = ref false in
+ let chunk_size = ref 0 in
+
+ object
+ inherit t_from_refill ~bytes ()
+
+ method private refill (slice : Slice.t) : unit =
+ if !chunk_size = 0 && not !eof then (
+ chunk_size := read_next_chunk_len ();
+ if !chunk_size = 0 then eof := true (* stream is finished *)
+ );
+ slice.off <- 0;
+ slice.len <- 0;
+ if !chunk_size > 0 then (
+ (* read the whole chunk, or [Bytes.length bytes] of it *)
+ let to_read = min !chunk_size (Bytes.length slice.bytes) in
+ read_exactly_
+ ~too_short:(fun () -> raise (fail "chunk is too short"))
+ ic slice.bytes to_read;
+ slice.len <- to_read;
+ chunk_size := !chunk_size - to_read
+ )
+
+ method close () = eof := true (* do not close underlying stream *)
+ end
+
+ (** Output a stream using chunked encoding *)
+ let output_chunked' ?buf (oc : #Iostream.Out_buf.t) (self : #t) : unit =
+ let oc' = Output.chunk_encoding ?buf oc ~close_rec:false in
+ match to_chan' oc' self with
+ | () -> Output.close oc'
+ | exception e ->
+ let bt = Printexc.get_raw_backtrace () in
+ Output.close oc';
+ Printexc.raise_with_backtrace e bt
+
+ (** print a stream as a series of chunks *)
+ let output_chunked ?buf (oc : out_channel) (self : #t) : unit =
+ output_chunked' ?buf (Output.of_out_channel oc) self
+end
+
+(** A writer abstraction. *)
+module Writer = struct
+ type t = { write: Output.t -> unit } [@@unboxed]
+ (** Writer.
+
+ A writer is a push-based stream of bytes.
+ Give it an output channel and it will write the bytes in it.
+
+ This is useful for responses: an http endpoint can return a writer
+ as its response's body; the writer is given access to the connection
+ to the client and can write into it as if it were a regular
+ [out_channel], including controlling calls to [flush].
+ Tiny_httpd will convert these writes into valid HTTP chunks.
+ @since 0.14
+ *)
+
+ let[@inline] make ~write () : t = { write }
+
+ (** Write into the channel. *)
+ let[@inline] write (oc : #Output.t) (self : t) : unit =
+ self.write (oc :> Output.t)
+
+ (** Empty writer, will output 0 bytes. *)
+ let empty : t = { write = ignore }
+
+ (** A writer that just emits the bytes from the given string. *)
+ let[@inline] of_string (str : string) : t =
+ let write oc = Iostream.Out.output_string oc str in
+ { write }
+
+ let[@inline] of_input (ic : #Input.t) : t =
+ { write = (fun oc -> Input.to_chan' oc ic) }
+end
+
+(** A TCP server abstraction. *)
+module TCP_server = struct
+ type conn_handler = {
+ handle: client_addr:Unix.sockaddr -> Input.t -> Output.t -> unit;
+ (** Handle client connection *)
+ }
+
+ type t = {
+ endpoint: unit -> string * int;
+ (** Endpoint we listen on. This can only be called from within [serve]. *)
+ active_connections: unit -> int;
+ (** Number of connections currently active *)
+ running: unit -> bool; (** Is the server currently running? *)
+ stop: unit -> unit;
+ (** Ask the server to stop. This might not take effect immediately,
+ and is idempotent. After this [server.running()] must return [false]. *)
+ }
+ (** A running TCP server.
+
+ This contains some functions that provide information about the running
+ server, including whether it's active (as opposed to stopped), a function
+ to stop it, and statistics about the number of connections. *)
+
+ type builder = {
+ serve: after_init:(t -> unit) -> handle:conn_handler -> unit -> unit;
+ (** Blocking call to listen for incoming connections and handle them.
+ Uses the connection handler [handle] to handle individual client
+ connections in individual threads/fibers/tasks.
+ @param after_init is called once with the server after the server
+ has started. *)
+ }
+ (** A TCP server builder implementation.
+
+ Calling [builder.serve ~after_init ~handle ()] starts a new TCP server on
+ an unspecified endpoint
+ (most likely coming from the function returning this builder)
+ and returns the running server. *)
+end
diff --git a/src/Tiny_httpd_buf.ml b/src/core/buf.ml
similarity index 96%
rename from src/Tiny_httpd_buf.ml
rename to src/core/buf.ml
index fcc89933..5824946f 100644
--- a/src/Tiny_httpd_buf.ml
+++ b/src/core/buf.ml
@@ -4,6 +4,7 @@ let create ?(size = 4_096) () : t =
let bytes = Bytes.make size ' ' in
{ bytes; i = 0; original = bytes }
+let of_bytes bytes : t = { bytes; i = 0; original = bytes }
let[@inline] size self = self.i
let[@inline] bytes_slice self = self.bytes
diff --git a/src/Tiny_httpd_buf.mli b/src/core/buf.mli
similarity index 97%
rename from src/Tiny_httpd_buf.mli
rename to src/core/buf.mli
index e5ca90c1..dbbbb7ca 100644
--- a/src/Tiny_httpd_buf.mli
+++ b/src/core/buf.mli
@@ -11,6 +11,7 @@ type t
val size : t -> int
val clear : t -> unit
val create : ?size:int -> unit -> t
+val of_bytes : bytes -> t
val contents : t -> string
val clear_and_zero : t -> unit
diff --git a/src/core/common_.ml b/src/core/common_.ml
new file mode 100644
index 00000000..1058feea
--- /dev/null
+++ b/src/core/common_.ml
@@ -0,0 +1,10 @@
+exception Bad_req of int * string
+
+let spf = Printf.sprintf
+let bad_reqf c fmt = Printf.ksprintf (fun s -> raise (Bad_req (c, s))) fmt
+
+type 'a resp_result = ('a, int * string) result
+
+let unwrap_resp_result = function
+ | Ok x -> x
+ | Error (c, s) -> raise (Bad_req (c, s))
diff --git a/src/core/dune b/src/core/dune
new file mode 100644
index 00000000..a04707ef
--- /dev/null
+++ b/src/core/dune
@@ -0,0 +1,18 @@
+
+(library
+ (name tiny_httpd_core)
+ (public_name tiny_httpd.core)
+ (private_modules parse_ common_)
+ (libraries threads seq hmap iostream
+ (select log.ml from
+ (logs -> log.logs.ml)
+ (-> log.default.ml))))
+
+(rule
+ (targets Atomic_.ml)
+ (deps
+ (:bin ./gen/mkshims.exe))
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin}))))
diff --git a/src/core/gen/dune b/src/core/gen/dune
new file mode 100644
index 00000000..cf54b00e
--- /dev/null
+++ b/src/core/gen/dune
@@ -0,0 +1,2 @@
+(executables
+ (names mkshims))
diff --git a/src/gen/mkshims.ml b/src/core/gen/mkshims.ml
similarity index 100%
rename from src/gen/mkshims.ml
rename to src/core/gen/mkshims.ml
diff --git a/src/core/headers.ml b/src/core/headers.ml
new file mode 100644
index 00000000..a06a6439
--- /dev/null
+++ b/src/core/headers.ml
@@ -0,0 +1,70 @@
+open Common_
+
+type t = (string * string) list
+
+let empty = []
+
+let contains name headers =
+ let name' = String.lowercase_ascii name in
+ List.exists (fun (n, _) -> name' = n) headers
+
+let get_exn ?(f = fun x -> x) x h =
+ let x' = String.lowercase_ascii x in
+ List.assoc x' h |> f
+
+let get ?(f = fun x -> x) x h =
+ try Some (get_exn ~f x h) with Not_found -> None
+
+let remove x h =
+ let x' = String.lowercase_ascii x in
+ List.filter (fun (k, _) -> k <> x') h
+
+let set x y h =
+ let x' = String.lowercase_ascii x in
+ (x', y) :: List.filter (fun (k, _) -> k <> x') h
+
+let pp out l =
+ let pp_pair out (k, v) = Format.fprintf out "@[%s: %s@]" k v in
+ Format.fprintf out "@[%a@]" (Format.pp_print_list pp_pair) l
+
+(* token = 1*tchar
+ tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" / "_"
+ / "`" / "|" / "~" / DIGIT / ALPHA ; any VCHAR, except delimiters
+ Reference: https://datatracker.ietf.org/doc/html/rfc7230#section-3.2 *)
+let is_tchar = function
+ | '0' .. '9'
+ | 'a' .. 'z'
+ | 'A' .. 'Z'
+ | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' | '_' | '`'
+ | '|' | '~' ->
+ true
+ | _ -> false
+
+let for_all pred s =
+ try
+ String.iter (fun c -> if not (pred c) then raise Exit) s;
+ true
+ with Exit -> false
+
+let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
+ let rec loop acc =
+ match IO.Input.read_line_using_opt ~buf bs with
+ | None -> raise End_of_file
+ | Some "\r" -> acc
+ | Some line ->
+ Log.debug (fun k -> k "parsed header line %S" line);
+ let k, v =
+ try
+ let i = String.index line ':' in
+ let k = String.sub line 0 i in
+ if not (for_all is_tchar k) then
+ invalid_arg (Printf.sprintf "Invalid header key: %S" k);
+ let v =
+ String.sub line (i + 1) (String.length line - i - 1) |> String.trim
+ in
+ k, v
+ with _ -> bad_reqf 400 "invalid header line: %S" line
+ in
+ loop ((String.lowercase_ascii k, v) :: acc)
+ in
+ loop []
diff --git a/src/core/headers.mli b/src/core/headers.mli
new file mode 100644
index 00000000..b46b5d54
--- /dev/null
+++ b/src/core/headers.mli
@@ -0,0 +1,35 @@
+(** Headers
+
+ Headers are metadata associated with a request or response. *)
+
+type t = (string * string) list
+(** The header files of a request or response.
+
+ Neither the key nor the value can contain ['\r'] or ['\n'].
+ See https://tools.ietf.org/html/rfc7230#section-3.2 *)
+
+val empty : t
+(** Empty list of headers.
+ @since 0.5 *)
+
+val get : ?f:(string -> string) -> string -> t -> string option
+(** [get k headers] looks for the header field with key [k].
+ @param f if provided, will transform the value before it is returned. *)
+
+val get_exn : ?f:(string -> string) -> string -> t -> string
+(** @raise Not_found *)
+
+val set : string -> string -> t -> t
+(** [set k v headers] sets the key [k] to value [v].
+ It erases any previous entry for [k] *)
+
+val remove : string -> t -> t
+(** Remove the key from the headers, if present. *)
+
+val contains : string -> t -> bool
+(** Is there a header with the given key? *)
+
+val pp : Format.formatter -> t -> unit
+(** Pretty print the headers. *)
+
+val parse_ : buf:Buf.t -> IO.Input.t -> t
diff --git a/src/Tiny_httpd_log.default.ml b/src/core/log.default.ml
similarity index 100%
rename from src/Tiny_httpd_log.default.ml
rename to src/core/log.default.ml
diff --git a/src/Tiny_httpd_log.logs.ml b/src/core/log.logs.ml
similarity index 100%
rename from src/Tiny_httpd_log.logs.ml
rename to src/core/log.logs.ml
diff --git a/src/Tiny_httpd_log.mli b/src/core/log.mli
similarity index 100%
rename from src/Tiny_httpd_log.mli
rename to src/core/log.mli
diff --git a/src/core/meth.ml b/src/core/meth.ml
new file mode 100644
index 00000000..94e6bb3a
--- /dev/null
+++ b/src/core/meth.ml
@@ -0,0 +1,22 @@
+open Common_
+
+type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
+
+let to_string = function
+ | `GET -> "GET"
+ | `PUT -> "PUT"
+ | `HEAD -> "HEAD"
+ | `POST -> "POST"
+ | `DELETE -> "DELETE"
+ | `OPTIONS -> "OPTIONS"
+
+let pp out s = Format.pp_print_string out (to_string s)
+
+let of_string = function
+ | "GET" -> `GET
+ | "PUT" -> `PUT
+ | "POST" -> `POST
+ | "HEAD" -> `HEAD
+ | "DELETE" -> `DELETE
+ | "OPTIONS" -> `OPTIONS
+ | s -> bad_reqf 400 "unknown method %S" s
diff --git a/src/core/meth.mli b/src/core/meth.mli
new file mode 100644
index 00000000..76b2c942
--- /dev/null
+++ b/src/core/meth.mli
@@ -0,0 +1,11 @@
+(** HTTP Methods *)
+
+type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
+(** A HTTP method.
+ For now we only handle a subset of these.
+
+ See https://tools.ietf.org/html/rfc7231#section-4 *)
+
+val pp : Format.formatter -> t -> unit
+val to_string : t -> string
+val of_string : string -> t
diff --git a/src/Tiny_httpd_parse_.ml b/src/core/parse_.ml
similarity index 100%
rename from src/Tiny_httpd_parse_.ml
rename to src/core/parse_.ml
diff --git a/src/Tiny_httpd_pool.ml b/src/core/pool.ml
similarity index 97%
rename from src/Tiny_httpd_pool.ml
rename to src/core/pool.ml
index 1a441944..fc9a0461 100644
--- a/src/Tiny_httpd_pool.ml
+++ b/src/core/pool.ml
@@ -1,4 +1,4 @@
-module A = Tiny_httpd_atomic_
+module A = Atomic_
type 'a list_ = Nil | Cons of int * 'a * 'a list_
diff --git a/src/Tiny_httpd_pool.mli b/src/core/pool.mli
similarity index 100%
rename from src/Tiny_httpd_pool.mli
rename to src/core/pool.mli
diff --git a/src/core/request.ml b/src/core/request.ml
new file mode 100644
index 00000000..1a3275df
--- /dev/null
+++ b/src/core/request.ml
@@ -0,0 +1,231 @@
+open Common_
+
+type 'body t = {
+ meth: Meth.t;
+ host: string;
+ client_addr: Unix.sockaddr;
+ headers: Headers.t;
+ mutable meta: Hmap.t;
+ http_version: int * int;
+ path: string;
+ path_components: string list;
+ query: (string * string) list;
+ body: 'body;
+ start_time: float;
+}
+
+let headers self = self.headers
+let host self = self.host
+let client_addr self = self.client_addr
+let meth self = self.meth
+let path self = self.path
+let body self = self.body
+let start_time self = self.start_time
+let query self = self.query
+let get_header ?f self h = Headers.get ?f h self.headers
+let remove_header k self = { self with headers = Headers.remove k self.headers }
+let add_meta self k v = self.meta <- Hmap.add k v self.meta
+let get_meta self k = Hmap.find k self.meta
+let get_meta_exn self k = Hmap.get k self.meta
+
+let get_header_int self h =
+ match get_header self h with
+ | Some x -> (try Some (int_of_string x) with _ -> None)
+ | None -> None
+
+let set_header k v self = { self with headers = Headers.set k v self.headers }
+let update_headers f self = { self with headers = f self.headers }
+let set_body b self = { self with body = b }
+
+(** Should we close the connection after this request? *)
+let close_after_req (self : _ t) : bool =
+ match self.http_version with
+ | 1, 1 -> get_header self "connection" = Some "close"
+ | 1, 0 -> not (get_header self "connection" = Some "keep-alive")
+ | _ -> false
+
+let pp_comp_ out comp =
+ Format.fprintf out "[%s]"
+ (String.concat ";" @@ List.map (Printf.sprintf "%S") comp)
+
+let pp_query out q =
+ Format.fprintf out "[%s]"
+ (String.concat ";" @@ List.map (fun (a, b) -> Printf.sprintf "%S,%S" a b) q)
+
+let pp_with ?(mask_header = fun _ -> false)
+ ?(headers_to_mask = [ "authorization"; "cookie" ]) ?(show_query = true)
+ ?(pp_body = fun out _ -> Format.pp_print_string out "?") () out self : unit
+ =
+ let pp_query out q =
+ if show_query then
+ pp_query out q
+ else
+ Format.fprintf out ""
+ in
+
+ let headers_to_mask = List.rev_map String.lowercase_ascii headers_to_mask in
+ (* hide some headers *)
+ let headers =
+ List.map
+ (fun (k, v) ->
+ let hidden = List.mem k headers_to_mask || mask_header k in
+ if hidden then
+ k, ""
+ else
+ k, v)
+ self.headers
+ in
+ Format.fprintf out
+ "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ body=%a;@ \
+ path_components=%a;@ query=%a@]}"
+ (Meth.to_string self.meth) self.host Headers.pp headers self.path pp_body
+ self.body pp_comp_ self.path_components pp_query self.query
+
+let pp_ out self : unit = pp_with () out self
+
+let pp out self : unit =
+ let pp_body out b = Format.fprintf out "%S" b in
+ pp_with ~pp_body () out self
+
+(* decode a "chunked" stream into a normal stream *)
+let read_stream_chunked_ ~bytes (bs : #IO.Input.t) : IO.Input.t =
+ Log.debug (fun k -> k "body: start reading chunked stream...");
+ IO.Input.read_chunked ~bytes ~fail:(fun s -> Bad_req (400, s)) bs
+
+let limit_body_size_ ~max_size ~bytes (bs : #IO.Input.t) : IO.Input.t =
+ Log.debug (fun k -> k "limit size of body to max-size=%d" max_size);
+ IO.Input.limit_size_to ~max_size ~close_rec:false ~bytes bs
+
+let limit_body_size ~max_size ~bytes (req : IO.Input.t t) : IO.Input.t t =
+ { req with body = limit_body_size_ ~max_size ~bytes req.body }
+
+(** read exactly [size] bytes from the stream *)
+let read_exactly ~size ~bytes (bs : #IO.Input.t) : IO.Input.t =
+ Log.debug (fun k -> k "body: must read exactly %d bytes" size);
+ IO.Input.reading_exactly bs ~close_rec:false ~bytes ~size
+
+(* parse request, but not body (yet) *)
+let parse_req_start ~client_addr ~get_time_s ~buf (bs : IO.Input.t) :
+ unit t option resp_result =
+ try
+ let line = IO.Input.read_line_using ~buf bs in
+ Log.debug (fun k -> k "parse request line: %s" line);
+ let start_time = get_time_s () in
+ let meth, path, version =
+ try
+ let off = ref 0 in
+ let meth = Parse_.word line off in
+ let path = Parse_.word line off in
+ let http_version = Parse_.word line off in
+ let version =
+ match http_version with
+ | "HTTP/1.1" -> 1
+ | "HTTP/1.0" -> 0
+ | v -> invalid_arg (spf "unsupported HTTP version: %s" v)
+ in
+ meth, path, version
+ with
+ | Invalid_argument msg ->
+ Log.error (fun k -> k "invalid request line: `%s`: %s" line msg);
+ raise (Bad_req (400, "Invalid request line"))
+ | _ ->
+ Log.error (fun k -> k "invalid request line: `%s`" line);
+ raise (Bad_req (400, "Invalid request line"))
+ in
+ let meth = Meth.of_string meth in
+ Log.debug (fun k -> k "got meth: %s, path %S" (Meth.to_string meth) path);
+ let headers = Headers.parse_ ~buf bs in
+ let host =
+ match Headers.get "Host" headers with
+ | None -> bad_reqf 400 "No 'Host' header in request"
+ | Some h -> h
+ in
+ let path_components, query = Util.split_query path in
+ let path_components = Util.split_on_slash path_components in
+ let query =
+ match Util.parse_query query with
+ | Ok l -> l
+ | Error e -> bad_reqf 400 "invalid query: %s" e
+ in
+ let req =
+ {
+ meth;
+ query;
+ host;
+ meta = Hmap.empty;
+ client_addr;
+ path;
+ path_components;
+ headers;
+ http_version = 1, version;
+ body = ();
+ start_time;
+ }
+ in
+ Ok (Some req)
+ with
+ | End_of_file | Sys_error _ | Unix.Unix_error _ -> Ok None
+ | Bad_req (c, s) -> Error (c, s)
+ | e -> Error (400, Printexc.to_string e)
+
+(* parse body, given the headers.
+ @param tr_stream a transformation of the input stream. *)
+let parse_body_ ~tr_stream ~bytes (req : IO.Input.t t) :
+ IO.Input.t t resp_result =
+ try
+ let size, has_size =
+ match Headers.get_exn "Content-Length" req.headers |> int_of_string with
+ | n -> n, true (* body of fixed size *)
+ | exception Not_found -> 0, false
+ | exception _ -> bad_reqf 400 "invalid content-length"
+ in
+ let body =
+ match get_header ~f:String.trim req "Transfer-Encoding" with
+ | None -> read_exactly ~size ~bytes @@ tr_stream req.body
+ | Some "chunked" when has_size ->
+ bad_reqf 400 "specifying both transfer-encoding and content-length"
+ | Some "chunked" ->
+ (* body sent by chunks *)
+ let bs : IO.Input.t =
+ read_stream_chunked_ ~bytes @@ tr_stream req.body
+ in
+ if size > 0 then (
+ (* TODO: ensure we recycle [bytes] when the new input is closed *)
+ let bytes = Bytes.create 4096 in
+ limit_body_size_ ~max_size:size ~bytes bs
+ ) else
+ bs
+ | Some s -> bad_reqf 500 "cannot handle transfer encoding: %s" s
+ in
+ Ok { req with body }
+ with
+ | End_of_file -> Error (400, "unexpected end of file")
+ | Bad_req (c, s) -> Error (c, s)
+ | e -> Error (400, Printexc.to_string e)
+
+let read_body_full ?bytes ?buf_size (self : IO.Input.t t) : string t =
+ try
+ let buf =
+ match bytes with
+ | Some b -> Buf.of_bytes b
+ | None -> Buf.create ?size:buf_size ()
+ in
+ let body = IO.Input.read_all_using ~buf self.body in
+ { self with body }
+ with
+ | Bad_req _ as e -> raise e
+ | e -> bad_reqf 500 "failed to read body: %s" (Printexc.to_string e)
+
+module Private_ = struct
+ let close_after_req = close_after_req
+ let parse_req_start = parse_req_start
+
+ let parse_req_start_exn ?(buf = Buf.create ()) ~client_addr ~get_time_s bs =
+ parse_req_start ~client_addr ~get_time_s ~buf bs |> unwrap_resp_result
+
+ let parse_body ?(bytes = Bytes.create 4096) req bs : _ t =
+ parse_body_ ~tr_stream:(fun s -> s) ~bytes { req with body = bs }
+ |> unwrap_resp_result
+
+ let[@inline] set_body body self = { self with body }
+end
diff --git a/src/core/request.mli b/src/core/request.mli
new file mode 100644
index 00000000..e4242bcf
--- /dev/null
+++ b/src/core/request.mli
@@ -0,0 +1,168 @@
+(** Requests
+
+ Requests are sent by a client, e.g. a web browser or cURL.
+ From the point of view of the server, they're inputs. *)
+
+open Common_
+
+type 'body t = private {
+ meth: Meth.t; (** HTTP method for this request. *)
+ host: string;
+ (** Host header, mandatory. It can also be found in {!headers}. *)
+ client_addr: Unix.sockaddr; (** Client address. Available since 0.14. *)
+ headers: Headers.t; (** List of headers. *)
+ mutable meta: Hmap.t; (** Metadata. @since NEXT_RELEASE *)
+ http_version: int * int;
+ (** HTTP version. This should be either [1, 0] or [1, 1]. *)
+ path: string; (** Full path of the requested URL. *)
+ path_components: string list;
+ (** Components of the path of the requested URL. *)
+ query: (string * string) list; (** Query part of the requested URL. *)
+ body: 'body; (** Body of the request. *)
+ start_time: float;
+ (** Obtained via [get_time_s] in {!create}
+ @since 0.11 *)
+}
+(** A request with method, path, host, headers, and a body, sent by a client.
+
+ The body is polymorphic because the request goes through
+ several transformations. First it has no body, as only the request
+ and headers are read; then it has a stream body; then the body might be
+ entirely read as a string via {!read_body_full}.
+
+ @since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"]
+ @since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"].
+ @since 0.11 the type is a private alias
+ @since 0.11 the field [start_time] was added
+ *)
+
+val add_meta : _ t -> 'a Hmap.key -> 'a -> unit
+(** Add metadata
+ @since NEXT_RELEASE *)
+
+val get_meta : _ t -> 'a Hmap.key -> 'a option
+(** Get metadata
+ @since NEXT_RELEASE *)
+
+val get_meta_exn : _ t -> 'a Hmap.key -> 'a
+(** Like {!get_meta} but can fail
+ @raise Invalid_argument if not present
+ @since NEXT_RELEASE *)
+
+val pp_with :
+ ?mask_header:(string -> bool) ->
+ ?headers_to_mask:string list ->
+ ?show_query:bool ->
+ ?pp_body:(Format.formatter -> 'body -> unit) ->
+ unit ->
+ Format.formatter ->
+ 'body t ->
+ unit
+(** Pretty print the request. The exact format of this printing
+ is not specified.
+ @param mask_header function which is given each header name. If it
+ returns [true], the header's value is masked. The presence of
+ the header is still printed. Default [fun _ -> false].
+ @param headers_to_mask a list of headers masked by default.
+ Default is ["authorization"; "cookie"].
+ @show_query if [true] (default [true]), the query part of the
+ request is shown.
+ @param pp_body body printer (default prints "?" instead of the body,
+ which works even for stream bodies) *)
+
+val pp : Format.formatter -> string t -> unit
+(** Pretty print the request and its body. The exact format of this printing
+ is not specified. *)
+
+val pp_ : Format.formatter -> _ t -> unit
+(** Pretty print the request without its body. The exact format of this printing
+ is not specified. *)
+
+val headers : _ t -> Headers.t
+(** List of headers of the request, including ["Host"]. *)
+
+val get_header : ?f:(string -> string) -> _ t -> string -> string option
+(** [get_header req h] looks up header [h] in [req]. It returns [None] if the
+ header is not present. This is case insensitive and should be used
+ rather than looking up [h] verbatim in [headers]. *)
+
+val get_header_int : _ t -> string -> int option
+(** Same as {!get_header} but also performs a string to integer conversion. *)
+
+val set_header : string -> string -> 'a t -> 'a t
+(** [set_header k v req] sets [k: v] in the request [req]'s headers. *)
+
+val remove_header : string -> 'a t -> 'a t
+(** Remove one instance of this header.
+ @since NEXT_RELEASE *)
+
+val update_headers : (Headers.t -> Headers.t) -> 'a t -> 'a t
+(** Modify headers using the given function.
+ @since 0.11 *)
+
+val set_body : 'a -> _ t -> 'a t
+(** [set_body b req] returns a new query whose body is [b].
+ @since 0.11 *)
+
+val host : _ t -> string
+(** Host field of the request. It also appears in the headers. *)
+
+val client_addr : _ t -> Unix.sockaddr
+(** Client address of the request.
+ @since 0.16 *)
+
+val meth : _ t -> Meth.t
+(** Method for the request. *)
+
+val path : _ t -> string
+(** Request path. *)
+
+val query : _ t -> (string * string) list
+(** Decode the query part of the {!path} field.
+ @since 0.4 *)
+
+val body : 'b t -> 'b
+(** Request body, possibly empty. *)
+
+val start_time : _ t -> float
+(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the request
+ @since 0.11 *)
+
+val limit_body_size :
+ max_size:int -> bytes:bytes -> IO.Input.t t -> IO.Input.t t
+(** Limit the body size to [max_size] bytes, or return
+ a [413] error.
+ @since 0.3
+ *)
+
+val read_body_full : ?bytes:bytes -> ?buf_size:int -> IO.Input.t t -> string t
+(** Read the whole body into a string. Potentially blocking.
+
+ @param buf_size initial size of underlying buffer (since 0.11)
+ @param bytes the initial buffer (since 0.14)
+ *)
+
+(**/**)
+
+(* for internal usage, do not use. There is no guarantee of stability. *)
+module Private_ : sig
+ val parse_req_start :
+ client_addr:Unix.sockaddr ->
+ get_time_s:(unit -> float) ->
+ buf:Buf.t ->
+ IO.Input.t ->
+ unit t option resp_result
+
+ val parse_req_start_exn :
+ ?buf:Buf.t ->
+ client_addr:Unix.sockaddr ->
+ get_time_s:(unit -> float) ->
+ IO.Input.t ->
+ unit t option
+
+ val close_after_req : _ t -> bool
+ val parse_body : ?bytes:bytes -> unit t -> IO.Input.t -> IO.Input.t t
+ val set_body : 'a -> _ t -> 'a t
+end
+
+(**/**)
diff --git a/src/core/response.ml b/src/core/response.ml
new file mode 100644
index 00000000..e1d2721a
--- /dev/null
+++ b/src/core/response.ml
@@ -0,0 +1,164 @@
+open Common_
+
+type body =
+ [ `String of string | `Stream of IO.Input.t | `Writer of IO.Writer.t | `Void ]
+
+type t = { code: Response_code.t; headers: Headers.t; body: body }
+
+let set_body body self = { self with body }
+let set_headers headers self = { self with headers }
+let update_headers f self = { self with headers = f self.headers }
+let set_header k v self = { self with headers = Headers.set k v self.headers }
+let remove_header k self = { self with headers = Headers.remove k self.headers }
+let set_code code self = { self with code }
+
+let make_raw ?(headers = []) ~code body : t =
+ (* add content length to response *)
+ let headers =
+ Headers.set "Content-Length" (string_of_int (String.length body)) headers
+ in
+ { code; headers; body = `String body }
+
+let make_raw_stream ?(headers = []) ~code body : t =
+ let headers = Headers.set "Transfer-Encoding" "chunked" headers in
+ { code; headers; body = `Stream body }
+
+let make_raw_writer ?(headers = []) ~code body : t =
+ let headers = Headers.set "Transfer-Encoding" "chunked" headers in
+ { code; headers; body = `Writer body }
+
+let make_void_force_ ?(headers = []) ~code () : t =
+ { code; headers; body = `Void }
+
+let make_void ?(headers = []) ~code () : t =
+ let is_ok = code < 200 || code = 204 || code = 304 in
+ if is_ok then
+ make_void_force_ ~headers ~code ()
+ else
+ make_raw ~headers ~code "" (* invalid to not have a body *)
+
+let make_string ?headers ?(code = 200) r =
+ match r with
+ | Ok body -> make_raw ?headers ~code body
+ | Error (code, msg) -> make_raw ?headers ~code msg
+
+let make_stream ?headers ?(code = 200) r =
+ match r with
+ | Ok body -> make_raw_stream ?headers ~code body
+ | Error (code, msg) -> make_raw ?headers ~code msg
+
+let make_writer ?headers ?(code = 200) r : t =
+ match r with
+ | Ok body -> make_raw_writer ?headers ~code body
+ | Error (code, msg) -> make_raw ?headers ~code msg
+
+let make ?headers ?(code = 200) r : t =
+ match r with
+ | Ok (`String body) -> make_raw ?headers ~code body
+ | Ok (`Stream body) -> make_raw_stream ?headers ~code body
+ | Ok `Void -> make_void ?headers ~code ()
+ | Ok (`Writer f) -> make_raw_writer ?headers ~code f
+ | Error (code, msg) -> make_raw ?headers ~code msg
+
+let fail ?headers ~code fmt =
+ Printf.ksprintf (fun msg -> make_raw ?headers ~code msg) fmt
+
+exception Bad_req = Bad_req
+
+let fail_raise ~code fmt =
+ Printf.ksprintf (fun msg -> raise (Bad_req (code, msg))) fmt
+
+let pp out self : unit =
+ let pp_body out = function
+ | `String s -> Format.fprintf out "%S" s
+ | `Stream _ -> Format.pp_print_string out ""
+ | `Writer _ -> Format.pp_print_string out ""
+ | `Void -> ()
+ in
+ Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" self.code
+ Headers.pp self.headers pp_body self.body
+
+let output_ ~bytes (oc : IO.Output.t) (self : t) : unit =
+ (* double indirection:
+ - print into [buffer] using [bprintf]
+ - transfer to [buf_] so we can output from there *)
+ let tmp_buffer = Buffer.create 32 in
+ let buf = Buf.of_bytes bytes in
+
+ (* write start of reply *)
+ Printf.bprintf tmp_buffer "HTTP/1.1 %d %s\r\n" self.code
+ (Response_code.descr self.code);
+ Buf.add_buffer buf tmp_buffer;
+ Buffer.clear tmp_buffer;
+
+ let body, is_chunked =
+ match self.body with
+ | `String s when String.length s > 1024 * 500 ->
+ (* chunk-encode large bodies *)
+ `Writer (IO.Writer.of_string s), true
+ | `String _ as b -> b, false
+ | `Stream _ as b -> b, true
+ | `Writer _ as b -> b, true
+ | `Void as b -> b, false
+ in
+ let headers =
+ if is_chunked then
+ self.headers
+ |> Headers.set "transfer-encoding" "chunked"
+ |> Headers.remove "content-length"
+ else
+ self.headers
+ in
+ let self = { self with headers; body } in
+ Log.debug (fun k ->
+ k "t[%d]: output response: %s"
+ (Thread.id @@ Thread.self ())
+ (Format.asprintf "%a" pp { self with body = `String "<...>" }));
+
+ (* write headers, using [buf] to batch writes *)
+ List.iter
+ (fun (k, v) ->
+ Printf.bprintf tmp_buffer "%s: %s\r\n" k v;
+ Buf.add_buffer buf tmp_buffer;
+ Buffer.clear tmp_buffer)
+ headers;
+
+ IO.Output.output_buf oc buf;
+ IO.Output.output_string oc "\r\n";
+ Buf.clear buf;
+
+ (match body with
+ | `String "" | `Void -> ()
+ | `String s -> IO.Output.output_string oc s
+ | `Writer w ->
+ (* use buffer to chunk encode [w] *)
+ let oc' = IO.Output.chunk_encoding ~buf ~close_rec:false oc in
+ (try
+ IO.Writer.write oc' w;
+ IO.Output.close oc'
+ with e ->
+ let bt = Printexc.get_raw_backtrace () in
+ IO.Output.close oc';
+ IO.Output.flush oc;
+ Printexc.raise_with_backtrace e bt)
+ | `Stream str ->
+ (match IO.Input.output_chunked' ~buf oc str with
+ | () ->
+ Log.debug (fun k ->
+ k "t[%d]: done outputing stream" (Thread.id @@ Thread.self ()));
+ IO.Input.close str
+ | exception e ->
+ let bt = Printexc.get_raw_backtrace () in
+ Log.error (fun k ->
+ k "t[%d]: outputing stream failed with %s"
+ (Thread.id @@ Thread.self ())
+ (Printexc.to_string e));
+ IO.Input.close str;
+ IO.Output.flush oc;
+ Printexc.raise_with_backtrace e bt));
+ IO.Output.flush oc
+
+module Private_ = struct
+ let make_void_force_ = make_void_force_
+ let output_ = output_
+end
diff --git a/src/core/response.mli b/src/core/response.mli
new file mode 100644
index 00000000..4cf0f192
--- /dev/null
+++ b/src/core/response.mli
@@ -0,0 +1,122 @@
+(** Responses
+
+ Responses are what a http server, such as {!Tiny_httpd}, send back to
+ the client to answer a {!Request.t}*)
+
+type body =
+ [ `String of string | `Stream of IO.Input.t | `Writer of IO.Writer.t | `Void ]
+(** Body of a response, either as a simple string,
+ or a stream of bytes, or nothing (for server-sent events notably).
+
+ - [`String str] replies with a body set to this string, and a known content-length.
+ - [`Stream str] replies with a body made from this string, using chunked encoding.
+ - [`Void] replies with no body.
+ - [`Writer w] replies with a body created by the writer [w], using
+ a chunked encoding.
+ It is available since 0.14.
+ *)
+
+type t = private {
+ code: Response_code.t; (** HTTP response code. See {!Response_code}. *)
+ headers: Headers.t;
+ (** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *)
+ body: body; (** Body of the response. Can be empty. *)
+}
+(** A response to send back to a client. *)
+
+val set_body : body -> t -> t
+(** Set the body of the response.
+ @since 0.11 *)
+
+val set_header : string -> string -> t -> t
+(** Set a header.
+ @since 0.11 *)
+
+val update_headers : (Headers.t -> Headers.t) -> t -> t
+(** Modify headers.
+ @since 0.11 *)
+
+val remove_header : string -> t -> t
+(** Remove one instance of this header.
+ @since NEXT_RELEASE *)
+
+val set_headers : Headers.t -> t -> t
+(** Set all headers.
+ @since 0.11 *)
+
+val set_code : Response_code.t -> t -> t
+(** Set the response code.
+ @since 0.11 *)
+
+val make_raw : ?headers:Headers.t -> code:Response_code.t -> string -> t
+(** Make a response from its raw components, with a string body.
+ Use [""] to not send a body at all. *)
+
+val make_raw_stream :
+ ?headers:Headers.t -> code:Response_code.t -> IO.Input.t -> t
+(** Same as {!make_raw} but with a stream body. The body will be sent with
+ the chunked transfer-encoding. *)
+
+val make_void : ?headers:Headers.t -> code:int -> unit -> t
+(** Return a response without a body at all.
+ @since 0.13 *)
+
+val make :
+ ?headers:Headers.t ->
+ ?code:int ->
+ (body, Response_code.t * string) result ->
+ t
+(** [make r] turns a result into a response.
+
+ - [make (Ok body)] replies with [200] and the body.
+ - [make (Error (code,msg))] replies with the given error code
+ and message as body.
+ *)
+
+val make_string :
+ ?headers:Headers.t ->
+ ?code:int ->
+ (string, Response_code.t * string) result ->
+ t
+(** Same as {!make} but with a string body. *)
+
+val make_writer :
+ ?headers:Headers.t ->
+ ?code:int ->
+ (IO.Writer.t, Response_code.t * string) result ->
+ t
+(** Same as {!make} but with a writer body. *)
+
+val make_stream :
+ ?headers:Headers.t ->
+ ?code:int ->
+ (IO.Input.t, Response_code.t * string) result ->
+ t
+(** Same as {!make} but with a stream body. *)
+
+val fail : ?headers:Headers.t -> code:int -> ('a, unit, string, t) format4 -> 'a
+(** Make the current request fail with the given code and message.
+ Example: [fail ~code:404 "oh noes, %s not found" "waldo"].
+ *)
+
+exception Bad_req of int * string
+(** Exception raised by {!fail_raise} with the HTTP code and body *)
+
+val fail_raise : code:int -> ('a, unit, string, 'b) format4 -> 'a
+(** Similar to {!fail} but raises an exception that exits the current handler.
+ This should not be used outside of a (path) handler.
+ Example: [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
+ @raise Bad_req always
+ *)
+
+val pp : Format.formatter -> t -> unit
+(** Pretty print the response. The exact format is not specified. *)
+
+(**/**)
+
+module Private_ : sig
+ val make_void_force_ : ?headers:Headers.t -> code:int -> unit -> t
+ val output_ : bytes:Bytes.t -> IO.Output.t -> t -> unit
+end
+
+(**/**)
diff --git a/src/core/response_code.ml b/src/core/response_code.ml
new file mode 100644
index 00000000..cc97380d
--- /dev/null
+++ b/src/core/response_code.ml
@@ -0,0 +1,32 @@
+type t = int
+
+let ok = 200
+let not_found = 404
+
+let descr = function
+ | 100 -> "Continue"
+ | 200 -> "OK"
+ | 201 -> "Created"
+ | 202 -> "Accepted"
+ | 204 -> "No content"
+ | 300 -> "Multiple choices"
+ | 301 -> "Moved permanently"
+ | 302 -> "Found"
+ | 304 -> "Not Modified"
+ | 400 -> "Bad request"
+ | 401 -> "Unauthorized"
+ | 403 -> "Forbidden"
+ | 404 -> "Not found"
+ | 405 -> "Method not allowed"
+ | 408 -> "Request timeout"
+ | 409 -> "Conflict"
+ | 410 -> "Gone"
+ | 411 -> "Length required"
+ | 413 -> "Payload too large"
+ | 417 -> "Expectation failed"
+ | 500 -> "Internal server error"
+ | 501 -> "Not implemented"
+ | 503 -> "Service unavailable"
+ | n -> "Unknown response code " ^ string_of_int n (* TODO *)
+
+let[@inline] is_success n = n >= 200 && n < 400
diff --git a/src/core/response_code.mli b/src/core/response_code.mli
new file mode 100644
index 00000000..fd0663d4
--- /dev/null
+++ b/src/core/response_code.mli
@@ -0,0 +1,20 @@
+(** Response Codes *)
+
+type t = int
+(** A standard HTTP code.
+
+ https://tools.ietf.org/html/rfc7231#section-6 *)
+
+val ok : t
+(** The code [200] *)
+
+val not_found : t
+(** The code [404] *)
+
+val descr : t -> string
+(** A description of some of the error codes.
+ NOTE: this is not complete (yet). *)
+
+val is_success : t -> bool
+(** [is_success code] is true iff [code] is in the [2xx] or [3xx] range.
+ @since NEXT_RELEASE *)
diff --git a/src/core/route.ml b/src/core/route.ml
new file mode 100644
index 00000000..f2e52f08
--- /dev/null
+++ b/src/core/route.ml
@@ -0,0 +1,93 @@
+type path = string list (* split on '/' *)
+
+type (_, _) comp =
+ | Exact : string -> ('a, 'a) comp
+ | Int : (int -> 'a, 'a) comp
+ | String : (string -> 'a, 'a) comp
+ | String_urlencoded : (string -> 'a, 'a) comp
+
+type (_, _) t =
+ | Fire : ('b, 'b) t
+ | Rest : { url_encoded: bool } -> (string -> 'b, 'b) t
+ | Compose : ('a, 'b) comp * ('b, 'c) t -> ('a, 'c) t
+
+let return = Fire
+let rest_of_path = Rest { url_encoded = false }
+let rest_of_path_urlencoded = Rest { url_encoded = true }
+let ( @/ ) a b = Compose (a, b)
+let string = String
+let string_urlencoded = String_urlencoded
+let int = Int
+let exact (s : string) = Exact s
+
+let exact_path (s : string) tail =
+ let rec fn = function
+ | [] -> tail
+ | "" :: ls -> fn ls
+ | s :: ls -> exact s @/ fn ls
+ in
+ fn (String.split_on_char '/' s)
+
+let rec eval : type a b. path -> (a, b) t -> a -> b option =
+ fun path route f ->
+ match path, route with
+ | [], Fire -> Some f
+ | _, Fire -> None
+ | _, Rest { url_encoded } ->
+ let whole_path = String.concat "/" path in
+ (match
+ if url_encoded then (
+ match Util.percent_decode whole_path with
+ | Some s -> s
+ | None -> raise_notrace Exit
+ ) else
+ whole_path
+ with
+ | whole_path -> Some (f whole_path)
+ | exception Exit -> None)
+ | c1 :: path', Compose (comp, route') ->
+ (match comp with
+ | Int ->
+ (match int_of_string c1 with
+ | i -> eval path' route' (f i)
+ | exception _ -> None)
+ | String -> eval path' route' (f c1)
+ | String_urlencoded ->
+ (match Util.percent_decode c1 with
+ | None -> None
+ | Some s -> eval path' route' (f s))
+ | Exact s ->
+ if s = c1 then
+ eval path' route' f
+ else
+ None)
+ | [], Compose (String, Fire) -> Some (f "") (* trailing *)
+ | [], Compose (String_urlencoded, Fire) -> Some (f "") (* trailing *)
+ | [], Compose _ -> None
+
+let bpf = Printf.bprintf
+
+let rec pp_ : type a b. Buffer.t -> (a, b) t -> unit =
+ fun out -> function
+ | Fire -> bpf out "/"
+ | Rest { url_encoded } ->
+ bpf out ""
+ (if url_encoded then
+ "_urlencoded"
+ else
+ "")
+ | Compose (Exact s, tl) -> bpf out "%s/%a" s pp_ tl
+ | Compose (Int, tl) -> bpf out "/%a" pp_ tl
+ | Compose (String, tl) -> bpf out "/%a" pp_ tl
+ | Compose (String_urlencoded, tl) -> bpf out "/%a" pp_ tl
+
+let to_string x =
+ let b = Buffer.create 16 in
+ pp_ b x;
+ Buffer.contents b
+
+module Private_ = struct
+ let eval = eval
+end
+
+let pp out x = Format.pp_print_string out (to_string x)
diff --git a/src/core/route.mli b/src/core/route.mli
new file mode 100644
index 00000000..4df45aba
--- /dev/null
+++ b/src/core/route.mli
@@ -0,0 +1,58 @@
+(** Routing
+
+ Basic type-safe routing of handlers based on URL paths. This is optional,
+ it is possible to only define the root handler with something like
+ {{: https://github.com/anuragsoni/routes/} Routes}.
+ @since 0.6 *)
+
+type ('a, 'b) comp
+(** An atomic component of a path *)
+
+type ('a, 'b) t
+(** A route, composed of path components *)
+
+val int : (int -> 'a, 'a) comp
+(** Matches an integer. *)
+
+val string : (string -> 'a, 'a) comp
+(** Matches a string not containing ['/'] and binds it as is. *)
+
+val string_urlencoded : (string -> 'a, 'a) comp
+(** Matches a URL-encoded string, and decodes it. *)
+
+val exact : string -> ('a, 'a) comp
+(** [exact "s"] matches ["s"] and nothing else. *)
+
+val return : ('a, 'a) t
+(** Matches the empty path. *)
+
+val rest_of_path : (string -> 'a, 'a) t
+(** Matches a string, even containing ['/']. This will match
+ the entirety of the remaining route.
+ @since 0.7 *)
+
+val rest_of_path_urlencoded : (string -> 'a, 'a) t
+(** Matches a string, even containing ['/'], an URL-decode it.
+ This will match the entirety of the remaining route.
+ @since 0.7 *)
+
+val ( @/ ) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t
+(** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"],
+ and [route] matches ["bar/…"]. *)
+
+val exact_path : string -> ('a, 'b) t -> ('a, 'b) t
+(** [exact_path "foo/bar/..." r] is equivalent to
+ [exact "foo" @/ exact "bar" @/ ... @/ r]
+ @since 0.11 **)
+
+val pp : Format.formatter -> _ t -> unit
+(** Print the route.
+ @since 0.7 *)
+
+val to_string : _ t -> string
+(** Print the route.
+ @since 0.7 *)
+
+module Private_ : sig
+ val eval : string list -> ('a, 'b) t -> 'a -> 'b option
+end
diff --git a/src/core/server.ml b/src/core/server.ml
new file mode 100644
index 00000000..1eb1715b
--- /dev/null
+++ b/src/core/server.ml
@@ -0,0 +1,514 @@
+open Common_
+
+type resp_error = Response_code.t * string
+
+module Middleware = struct
+ type handler = IO.Input.t Request.t -> resp:(Response.t -> unit) -> unit
+ type t = handler -> handler
+
+ (** Apply a list of middlewares to [h] *)
+ let apply_l (l : t list) (h : handler) : handler =
+ List.fold_right (fun m h -> m h) l h
+
+ let[@inline] nil : t = fun h -> h
+end
+
+(* a request handler. handles a single request. *)
+type cb_path_handler = IO.Output.t -> Middleware.handler
+
+module type SERVER_SENT_GENERATOR = sig
+ val set_headers : Headers.t -> unit
+
+ val send_event :
+ ?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
+
+ val close : unit -> unit
+end
+
+type server_sent_generator = (module SERVER_SENT_GENERATOR)
+
+(** Handler that upgrades to another protocol *)
+module type UPGRADE_HANDLER = sig
+ type handshake_state
+ (** Some specific state returned after handshake *)
+
+ val name : string
+ (** Name in the "upgrade" header *)
+
+ val handshake : unit Request.t -> (Headers.t * handshake_state, string) result
+ (** Perform the handshake and upgrade the connection. The returned
+ code is [101] alongside these headers. *)
+
+ val handle_connection :
+ Unix.sockaddr -> handshake_state -> IO.Input.t -> IO.Output.t -> unit
+ (** Take control of the connection and take it from there *)
+end
+
+type upgrade_handler = (module UPGRADE_HANDLER)
+
+exception Upgrade of unit Request.t * upgrade_handler
+
+module type IO_BACKEND = sig
+ val init_addr : unit -> string
+ val init_port : unit -> int
+
+ val get_time_s : unit -> float
+ (** obtain the current timestamp in seconds. *)
+
+ val tcp_server : unit -> IO.TCP_server.builder
+ (** Server that can listen on a port and handle clients. *)
+end
+
+type handler_result =
+ | Handle of (int * Middleware.t) list * cb_path_handler
+ | Fail of resp_error
+ | Upgrade of upgrade_handler
+
+let unwrap_handler_result req = function
+ | Handle (l, h) -> l, h
+ | Fail (c, s) -> raise (Bad_req (c, s))
+ | Upgrade up -> raise (Upgrade (req, up))
+
+type t = {
+ backend: (module IO_BACKEND);
+ mutable tcp_server: IO.TCP_server.t option;
+ mutable handler: IO.Input.t Request.t -> Response.t;
+ (** toplevel handler, if any *)
+ mutable middlewares: (int * Middleware.t) list; (** Global middlewares *)
+ mutable middlewares_sorted: (int * Middleware.t) list lazy_t;
+ (** sorted version of {!middlewares} *)
+ mutable path_handlers: (unit Request.t -> handler_result option) list;
+ (** path handlers *)
+ bytes_pool: bytes Pool.t;
+}
+
+let addr (self : t) =
+ match self.tcp_server with
+ | None ->
+ let (module B) = self.backend in
+ B.init_addr ()
+ | Some s -> fst @@ s.endpoint ()
+
+let port (self : t) =
+ match self.tcp_server with
+ | None ->
+ let (module B) = self.backend in
+ B.init_port ()
+ | Some s -> snd @@ s.endpoint ()
+
+let active_connections (self : t) =
+ match self.tcp_server with
+ | None -> 0
+ | Some s -> s.active_connections ()
+
+let sort_middlewares_ l =
+ List.stable_sort (fun (s1, _) (s2, _) -> compare s1 s2) l
+
+let add_middleware ~stage self m =
+ let stage =
+ match stage with
+ | `Encoding -> 0
+ | `Stage n when n < 1 -> invalid_arg "add_middleware: bad stage"
+ | `Stage n -> n
+ in
+ self.middlewares <- (stage, m) :: self.middlewares;
+ self.middlewares_sorted <- lazy (sort_middlewares_ self.middlewares)
+
+let add_decode_request_cb self f =
+ (* turn it into a middleware *)
+ let m h req ~resp =
+ (* see if [f] modifies the stream *)
+ let req0 = Request.Private_.set_body () req in
+ match f req0 with
+ | None -> h req ~resp (* pass through *)
+ | Some (req1, tr_stream) ->
+ let body = tr_stream req.Request.body in
+ let req = Request.set_body body req1 in
+ h req ~resp
+ in
+ add_middleware self ~stage:`Encoding m
+
+let add_encode_response_cb self f =
+ let m h req ~resp =
+ h req ~resp:(fun r ->
+ let req0 = Request.Private_.set_body () req in
+ (* now transform [r] if we want to *)
+ match f req0 r with
+ | None -> resp r
+ | Some r' -> resp r')
+ in
+ add_middleware self ~stage:`Encoding m
+
+let set_top_handler self f = self.handler <- f
+
+(* route the given handler.
+ @param tr_req wraps the actual concrete function returned by the route
+ and makes it into a handler. *)
+let add_route_handler_ ?(accept = fun _req -> Ok ()) ?(middlewares = []) ?meth
+ ~tr_req self (route : _ Route.t) f =
+ let middlewares = List.map (fun h -> 5, h) middlewares in
+ let ph req : handler_result option =
+ match meth with
+ | Some m when m <> req.Request.meth -> None (* ignore *)
+ | _ ->
+ (match Route.Private_.eval req.Request.path_components route f with
+ | Some handler ->
+ (* we have a handler, do we accept the request based on its headers? *)
+ (match accept req with
+ | Ok () ->
+ Some
+ (Handle
+ (middlewares, fun oc req ~resp -> tr_req oc req ~resp handler))
+ | Error err -> Some (Fail err))
+ | None -> None (* path didn't match *))
+ in
+ self.path_handlers <- ph :: self.path_handlers
+
+let add_route_handler (type a) ?accept ?middlewares ?meth self
+ (route : (a, _) Route.t) (f : _) : unit =
+ let tr_req _oc req ~resp f =
+ let req =
+ Pool.with_resource self.bytes_pool @@ fun bytes ->
+ Request.read_body_full ~bytes req
+ in
+ resp (f req)
+ in
+ add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f
+
+let add_route_handler_stream ?accept ?middlewares ?meth self route f =
+ let tr_req _oc req ~resp f = resp (f req) in
+ add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f
+
+let[@inline] _opt_iter ~f o =
+ match o with
+ | None -> ()
+ | Some x -> f x
+
+exception Exit_SSE
+
+let add_route_server_sent_handler ?accept self route f =
+ let tr_req (oc : IO.Output.t) req ~resp f =
+ let req =
+ Pool.with_resource self.bytes_pool @@ fun bytes ->
+ Request.read_body_full ~bytes req
+ in
+ let headers =
+ ref Headers.(empty |> set "content-type" "text/event-stream")
+ in
+
+ (* send response once *)
+ let resp_sent = ref false in
+ let send_response_idempotent_ () =
+ if not !resp_sent then (
+ resp_sent := true;
+ (* send 200 response now *)
+ let initial_resp =
+ Response.Private_.make_void_force_ ~headers:!headers ~code:200 ()
+ in
+ resp initial_resp
+ )
+ in
+
+ let[@inline] writef fmt =
+ Printf.ksprintf (IO.Output.output_string oc) fmt
+ in
+
+ let send_event ?event ?id ?retry ~data () : unit =
+ send_response_idempotent_ ();
+ _opt_iter event ~f:(fun e -> writef "event: %s\n" e);
+ _opt_iter id ~f:(fun e -> writef "id: %s\n" e);
+ _opt_iter retry ~f:(fun e -> writef "retry: %s\n" e);
+ let l = String.split_on_char '\n' data in
+ List.iter (fun s -> writef "data: %s\n" s) l;
+ IO.Output.output_string oc "\n";
+ (* finish group *)
+ IO.Output.flush oc
+ in
+ let module SSG = struct
+ let set_headers h =
+ if not !resp_sent then (
+ headers := List.rev_append h !headers;
+ send_response_idempotent_ ()
+ )
+
+ let send_event = send_event
+ let close () = raise Exit_SSE
+ end in
+ (try f req (module SSG : SERVER_SENT_GENERATOR)
+ with Exit_SSE -> IO.Output.close oc);
+ Log.info (fun k -> k "closed SSE connection")
+ in
+ add_route_handler_ self ?accept ~meth:`GET route ~tr_req f
+
+let add_upgrade_handler ?(accept = fun _ -> Ok ()) (self : t) route f : unit =
+ let ph req : handler_result option =
+ if req.Request.meth <> `GET then
+ None
+ else (
+ match accept req with
+ | Ok () ->
+ (match Route.Private_.eval req.Request.path_components route f with
+ | Some up -> Some (Upgrade up)
+ | None -> None (* path didn't match *))
+ | Error err -> Some (Fail err)
+ )
+ in
+ self.path_handlers <- ph :: self.path_handlers
+
+let clear_bytes_ bs = Bytes.fill bs 0 (Bytes.length bs) '\x00'
+
+let create_from ?(buf_size = 16 * 1_024) ?(middlewares = []) ~backend () : t =
+ let handler _req = Response.fail ~code:404 "no top handler" in
+ let self =
+ {
+ backend;
+ tcp_server = None;
+ handler;
+ path_handlers = [];
+ middlewares = [];
+ middlewares_sorted = lazy [];
+ bytes_pool =
+ Pool.create ~clear:clear_bytes_
+ ~mk_item:(fun () -> Bytes.create buf_size)
+ ();
+ }
+ in
+ List.iter (fun (stage, m) -> add_middleware self ~stage m) middlewares;
+ self
+
+let stop (self : t) =
+ match self.tcp_server with
+ | None -> ()
+ | Some s -> s.stop ()
+
+let running (self : t) =
+ match self.tcp_server with
+ | None -> false
+ | Some s -> s.running ()
+
+let find_map f l =
+ let rec aux f = function
+ | [] -> None
+ | x :: l' ->
+ (match f x with
+ | Some _ as res -> res
+ | None -> aux f l')
+ in
+ aux f l
+
+let string_as_list_contains_ (s : string) (sub : string) : bool =
+ let fragments = String.split_on_char ',' s in
+ List.exists (fun fragment -> String.trim fragment = sub) fragments
+
+(* handle client on [ic] and [oc] *)
+let client_handle_for (self : t) ~client_addr ic oc : unit =
+ Pool.with_resource self.bytes_pool @@ fun bytes_req ->
+ Pool.with_resource self.bytes_pool @@ fun bytes_res ->
+ let (module B) = self.backend in
+
+ (* how to log the response to this query *)
+ let log_response (req : _ Request.t) (resp : Response.t) =
+ if not Log.dummy then (
+ let msgf k =
+ let elapsed = B.get_time_s () -. req.start_time in
+ k
+ ("response to=%s code=%d time=%.3fs meth=%s path=%S" : _ format4)
+ (Util.show_sockaddr client_addr)
+ resp.code elapsed (Meth.to_string req.meth) req.path
+ in
+ if Response_code.is_success resp.code then
+ Log.info msgf
+ else
+ Log.error msgf
+ )
+ in
+
+ let log_exn msg bt =
+ Log.error (fun k ->
+ k "error while processing response for %s msg=%s@.%s"
+ (Util.show_sockaddr client_addr)
+ msg
+ (Printexc.raw_backtrace_to_string bt))
+ in
+
+ (* handle generic exception *)
+ let handle_exn e bt : unit =
+ let msg = Printexc.to_string e in
+ let resp = Response.fail ~code:500 "server error: %s" msg in
+ if not Log.dummy then log_exn msg bt;
+ Response.Private_.output_ ~bytes:bytes_res oc resp
+ in
+
+ let handle_bad_req req e bt =
+ let msg = Printexc.to_string e in
+ let resp = Response.fail ~code:500 "server error: %s" msg in
+ if not Log.dummy then (
+ log_exn msg bt;
+ log_response req resp
+ );
+ Response.Private_.output_ ~bytes:bytes_res oc resp
+ in
+
+ let handle_upgrade req (module UP : UPGRADE_HANDLER) : unit =
+ Log.debug (fun k -> k "upgrade connection");
+ try
+ (* check headers *)
+ (match Request.get_header req "connection" with
+ | Some str when string_as_list_contains_ str "Upgrade" -> ()
+ | _ -> bad_reqf 426 "connection header must contain 'Upgrade'");
+ (match Request.get_header req "upgrade" with
+ | Some u when u = UP.name -> ()
+ | Some u -> bad_reqf 426 "expected upgrade to be '%s', got '%s'" UP.name u
+ | None -> bad_reqf 426 "expected 'connection: upgrade' header");
+
+ (* ok, this is the upgrade we expected *)
+ match UP.handshake req with
+ | Error msg ->
+ (* fail the upgrade *)
+ Log.error (fun k -> k "upgrade failed: %s" msg);
+ let resp = Response.make_raw ~code:429 "upgrade required" in
+ log_response req resp;
+ Response.Private_.output_ ~bytes:bytes_res oc resp
+ | Ok (headers, handshake_st) ->
+ (* send the upgrade reply *)
+ let headers =
+ [ "connection", "upgrade"; "upgrade", UP.name ] @ headers
+ in
+ let resp = Response.make_string ~code:101 ~headers (Ok "") in
+ log_response req resp;
+ Response.Private_.output_ ~bytes:bytes_res oc resp;
+
+ UP.handle_connection client_addr handshake_st ic oc
+ with e ->
+ let bt = Printexc.get_raw_backtrace () in
+ handle_bad_req req e bt
+ in
+
+ let continue = ref true in
+
+ let handle_one_req () =
+ match
+ let buf = Buf.of_bytes bytes_req in
+ Request.Private_.parse_req_start ~client_addr ~get_time_s:B.get_time_s
+ ~buf ic
+ with
+ | Ok None -> continue := false (* client is done *)
+ | Error (c, s) ->
+ (* connection error, close *)
+ let res = Response.make_raw ~code:c s in
+ (try Response.Private_.output_ ~bytes:bytes_res oc res
+ with Sys_error _ -> ());
+ continue := false
+ | Ok (Some req) ->
+ Log.debug (fun k ->
+ k "t[%d]: parsed request: %s"
+ (Thread.id @@ Thread.self ())
+ (Format.asprintf "@[%a@]" Request.pp_ req));
+
+ if Request.Private_.close_after_req req then continue := false;
+
+ (try
+ (* is there a handler for this path? *)
+ let handler_middlewares, base_handler =
+ match find_map (fun ph -> ph req) self.path_handlers with
+ | Some f -> unwrap_handler_result req f
+ | None -> [], fun _oc req ~resp -> resp (self.handler req)
+ in
+
+ (* handle expect/continue *)
+ (match Request.get_header ~f:String.trim req "Expect" with
+ | Some "100-continue" ->
+ Log.debug (fun k -> k "send back: 100 CONTINUE");
+ Response.Private_.output_ ~bytes:bytes_res oc
+ (Response.make_raw ~code:100 "")
+ | Some s -> bad_reqf 417 "unknown expectation %s" s
+ | None -> ());
+
+ (* merge per-request middlewares with the server-global middlewares *)
+ let global_middlewares = Lazy.force self.middlewares_sorted in
+ let all_middlewares =
+ if handler_middlewares = [] then
+ global_middlewares
+ else
+ sort_middlewares_
+ (List.rev_append handler_middlewares self.middlewares)
+ in
+
+ (* apply middlewares *)
+ let handler oc =
+ List.fold_right
+ (fun (_, m) h -> m h)
+ all_middlewares (base_handler oc)
+ in
+
+ (* now actually read request's body into a stream *)
+ let req = Request.Private_.parse_body ~bytes:bytes_req req ic in
+
+ (* how to reply *)
+ let resp r =
+ try
+ if Headers.get "connection" r.Response.headers = Some "close" then
+ continue := false;
+ log_response req r;
+ Response.Private_.output_ ~bytes:bytes_res oc r
+ with Sys_error e ->
+ Log.debug (fun k ->
+ k "error when writing response: %s@.connection broken" e);
+ continue := false
+ in
+
+ (* call handler *)
+ try handler oc req ~resp
+ with Sys_error e ->
+ Log.debug (fun k ->
+ k "error while handling request: %s@.connection broken" e);
+ continue := false
+ with
+ | Sys_error e ->
+ (* connection broken somehow *)
+ Log.debug (fun k -> k "error: %s@. connection broken" e);
+ continue := false
+ | Bad_req (code, s) ->
+ continue := false;
+ let resp = Response.make_raw ~code s in
+ log_response req resp;
+ Response.Private_.output_ ~bytes:bytes_res oc resp
+ | Upgrade _ as e -> raise e
+ | e ->
+ let bt = Printexc.get_raw_backtrace () in
+ handle_bad_req req e bt)
+ in
+
+ try
+ while !continue && running self do
+ Log.debug (fun k ->
+ k "t[%d]: read next request" (Thread.id @@ Thread.self ()));
+ handle_one_req ()
+ done
+ with
+ | Upgrade (req, up) ->
+ (* upgrades take over the whole connection, we won't process
+ any further request *)
+ handle_upgrade req up
+ | e ->
+ let bt = Printexc.get_raw_backtrace () in
+ handle_exn e bt
+
+let client_handler (self : t) : IO.TCP_server.conn_handler =
+ { IO.TCP_server.handle = client_handle_for self }
+
+let is_ipv6 (self : t) =
+ let (module B) = self.backend in
+ Util.is_ipv6_str (B.init_addr ())
+
+let run_exn ?(after_init = ignore) (self : t) : unit =
+ let (module B) = self.backend in
+ let server = B.tcp_server () in
+ server.serve
+ ~after_init:(fun tcp_server ->
+ self.tcp_server <- Some tcp_server;
+ after_init ())
+ ~handle:(client_handler self) ()
+
+let run ?after_init self : _ result =
+ try Ok (run_exn ?after_init self) with e -> Error e
diff --git a/src/core/server.mli b/src/core/server.mli
new file mode 100644
index 00000000..e856c7e4
--- /dev/null
+++ b/src/core/server.mli
@@ -0,0 +1,298 @@
+(** HTTP server.
+
+ This module implements a very simple, basic HTTP/1.1 server using blocking
+ IOs and threads.
+
+ It is possible to use a thread pool, see {!create}'s argument [new_thread].
+
+ @since 0.13
+*)
+
+(** {2 Middlewares}
+
+ A middleware can be inserted in a handler to modify or observe
+ its behavior.
+
+ @since 0.11
+*)
+
+module Middleware : sig
+ type handler = IO.Input.t Request.t -> resp:(Response.t -> unit) -> unit
+ (** Handlers are functions returning a response to a request.
+ The response can be delayed, hence the use of a continuation
+ as the [resp] parameter. *)
+
+ type t = handler -> handler
+ (** A middleware is a handler transformation.
+
+ It takes the existing handler [h],
+ and returns a new one which, given a query, modify it or log it
+ before passing it to [h], or fail. It can also log or modify or drop
+ the response. *)
+
+ val nil : t
+ (** Trivial middleware that does nothing. *)
+end
+
+(** {2 Main Server type} *)
+
+type t
+(** A HTTP server. See {!create} for more details. *)
+
+(** A backend that provides IO operations, network operations, etc.
+
+ This is used to decouple tiny_httpd from the scheduler/IO library used to
+ actually open a TCP server and talk to clients. The classic way is
+ based on {!Unix} and blocking IOs, but it's also possible to
+ use an OCaml 5 library using effects and non blocking IOs. *)
+module type IO_BACKEND = sig
+ val init_addr : unit -> string
+ (** Initial TCP address *)
+
+ val init_port : unit -> int
+ (** Initial port *)
+
+ val get_time_s : unit -> float
+ (** Obtain the current timestamp in seconds. *)
+
+ val tcp_server : unit -> IO.TCP_server.builder
+ (** TCP server builder, to create servers that can listen
+ on a port and handle clients. *)
+end
+
+val create_from :
+ ?buf_size:int ->
+ ?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
+ backend:(module IO_BACKEND) ->
+ unit ->
+ t
+(** Create a new webserver using provided backend.
+
+ The server will not do anything until {!run} is called on it.
+ Before starting the server, one can use {!add_path_handler} and
+ {!set_top_handler} to specify how to handle incoming requests.
+
+ @param buf_size size for buffers (since 0.11)
+ @param middlewares see {!add_middleware} for more details.
+
+ @since 0.14
+*)
+
+val addr : t -> string
+(** Address on which the server listens. *)
+
+val is_ipv6 : t -> bool
+(** [is_ipv6 server] returns [true] iff the address of the server is an IPv6 address.
+ @since 0.3 *)
+
+val port : t -> int
+(** Port on which the server listens. Note that this might be different than
+ the port initially given if the port was [0] (meaning that the OS picks a
+ port for us). *)
+
+val active_connections : t -> int
+(** Number of currently active connections. *)
+
+val add_decode_request_cb :
+ t ->
+ (unit Request.t -> (unit Request.t * (IO.Input.t -> IO.Input.t)) option) ->
+ unit
+ [@@deprecated "use add_middleware"]
+(** Add a callback for every request.
+ The callback can provide a stream transformer and a new request (with
+ modified headers, typically).
+ A possible use is to handle decompression by looking for a [Transfer-Encoding]
+ header and returning a stream transformer that decompresses on the fly.
+
+ @deprecated use {!add_middleware} instead
+*)
+
+val add_encode_response_cb :
+ t -> (unit Request.t -> Response.t -> Response.t option) -> unit
+ [@@deprecated "use add_middleware"]
+(** Add a callback for every request/response pair.
+ Similarly to {!add_encode_response_cb} the callback can return a new
+ response, for example to compress it.
+ The callback is given the query with only its headers,
+ as well as the current response.
+
+ @deprecated use {!add_middleware} instead
+*)
+
+val add_middleware :
+ stage:[ `Encoding | `Stage of int ] -> t -> Middleware.t -> unit
+(** Add a middleware to every request/response pair.
+ @param stage specify when middleware applies.
+ Encoding comes first (outermost layer), then stages in increasing order.
+ @raise Invalid_argument if stage is [`Stage n] where [n < 1]
+ @since 0.11
+*)
+
+(** {2 Request handlers} *)
+
+val set_top_handler : t -> (IO.Input.t Request.t -> Response.t) -> unit
+(** Setup a handler called by default.
+
+ This handler is called with any request not accepted by any handler
+ installed via {!add_path_handler}.
+ If no top handler is installed, unhandled paths will return a [404] not found
+
+ This used to take a [string Request.t] but it now takes a [byte_stream Request.t]
+ since 0.14 . Use {!Request.read_body_full} to read the body into
+ a string if needed.
+*)
+
+val add_route_handler :
+ ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
+ ?middlewares:Middleware.t list ->
+ ?meth:Meth.t ->
+ t ->
+ ('a, string Request.t -> Response.t) Route.t ->
+ 'a ->
+ unit
+(** [add_route_handler server Route.(exact "path" @/ string @/ int @/ return) f]
+ calls [f "foo" 42 request] when a [request] with path "path/foo/42/"
+ is received.
+
+ Note that the handlers are called in the reverse order of their addition,
+ so the last registered handler can override previously registered ones.
+
+ @param meth if provided, only accept requests with the given method.
+ Typically one could react to [`GET] or [`PUT].
+ @param accept should return [Ok()] if the given request (before its body
+ is read) should be accepted, [Error (code,message)] if it's to be rejected (e.g. because
+ its content is too big, or for some permission error).
+ See the {!http_of_dir} program for an example of how to use [accept] to
+ filter uploads that are too large before the upload even starts.
+ The default always returns [Ok()], i.e. it accepts all requests.
+
+ @since 0.6
+*)
+
+val add_route_handler_stream :
+ ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
+ ?middlewares:Middleware.t list ->
+ ?meth:Meth.t ->
+ t ->
+ ('a, IO.Input.t Request.t -> Response.t) Route.t ->
+ 'a ->
+ unit
+(** Similar to {!add_route_handler}, but where the body of the request
+ is a stream of bytes that has not been read yet.
+ This is useful when one wants to stream the body directly into a parser,
+ json decoder (such as [Jsonm]) or into a file.
+ @since 0.6 *)
+
+(** {2 Server-sent events}
+
+ {b EXPERIMENTAL}: this API is not stable yet. *)
+
+(** A server-side function to generate of Server-sent events.
+
+ See {{: https://html.spec.whatwg.org/multipage/server-sent-events.html} the w3c page}
+ and {{: https://jvns.ca/blog/2021/01/12/day-36--server-sent-events-are-cool--and-a-fun-bug/}
+ this blog post}.
+
+ @since 0.9
+ *)
+module type SERVER_SENT_GENERATOR = sig
+ val set_headers : Headers.t -> unit
+ (** Set headers of the response.
+ This is not mandatory but if used at all, it must be called before
+ any call to {!send_event} (once events are sent the response is
+ already sent too). *)
+
+ val send_event :
+ ?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
+ (** Send an event from the server.
+ If data is a multiline string, it will be sent on separate "data:" lines. *)
+
+ val close : unit -> unit
+ (** Close connection.
+ @since 0.11 *)
+end
+
+type server_sent_generator = (module SERVER_SENT_GENERATOR)
+(** Server-sent event generator. This generates events that are forwarded to
+ the client (e.g. the browser).
+ @since 0.9 *)
+
+val add_route_server_sent_handler :
+ ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
+ t ->
+ ('a, string Request.t -> server_sent_generator -> unit) Route.t ->
+ 'a ->
+ unit
+(** Add a handler on an endpoint, that serves server-sent events.
+
+ The callback is given a generator that can be used to send events
+ as it pleases. The connection is always closed by the client,
+ and the accepted method is always [GET].
+ This will set the header "content-type" to "text/event-stream" automatically
+ and reply with a 200 immediately.
+ See {!server_sent_generator} for more details.
+
+ This handler stays on the original thread (it is synchronous).
+
+ @since 0.9 *)
+
+(** {2 Upgrade handlers}
+
+ These handlers upgrade the connection to another protocol.
+ @since NEXT_RELEASE *)
+
+(** Handler that upgrades to another protocol.
+ @since NEXT_RELEASE *)
+module type UPGRADE_HANDLER = sig
+ type handshake_state
+ (** Some specific state returned after handshake *)
+
+ val name : string
+ (** Name in the "upgrade" header *)
+
+ val handshake : unit Request.t -> (Headers.t * handshake_state, string) result
+ (** Perform the handshake and upgrade the connection. The returned
+ code is [101] alongside these headers.
+ In case the handshake fails, this only returns [Error log_msg].
+ The connection is closed without further ado. *)
+
+ val handle_connection :
+ Unix.sockaddr -> handshake_state -> IO.Input.t -> IO.Output.t -> unit
+ (** Take control of the connection and take it from ther.e *)
+end
+
+type upgrade_handler = (module UPGRADE_HANDLER)
+(** @since NEXT_RELEASE *)
+
+val add_upgrade_handler :
+ ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
+ t ->
+ ('a, upgrade_handler) Route.t ->
+ 'a ->
+ unit
+
+(** {2 Run the server} *)
+
+val running : t -> bool
+(** Is the server running?
+ @since 0.14 *)
+
+val stop : t -> unit
+(** Ask the server to stop. This might not have an immediate effect
+ as {!run} might currently be waiting on IO. *)
+
+val run : ?after_init:(unit -> unit) -> t -> (unit, exn) result
+(** Run the main loop of the server, listening on a socket
+ described at the server's creation time, using [new_thread] to
+ start a thread for each new client.
+
+ This returns [Ok ()] if the server exits gracefully, or [Error e] if
+ it exits with an error.
+
+ @param after_init is called after the server starts listening. since 0.13 .
+*)
+
+val run_exn : ?after_init:(unit -> unit) -> t -> unit
+(** [run_exn s] is like [run s] but re-raises an exception if the server exits
+ with an error.
+ @since 0.14 *)
diff --git a/src/Tiny_httpd_stream.ml b/src/core/stream.ml.tmp
similarity index 89%
rename from src/Tiny_httpd_stream.ml
rename to src/core/stream.ml.tmp
index a845c8bf..607a4f5f 100644
--- a/src/Tiny_httpd_stream.ml
+++ b/src/core/stream.ml.tmp
@@ -1,3 +1,4 @@
+(*
module Buf = Tiny_httpd_buf
module IO = Tiny_httpd_io
@@ -184,36 +185,6 @@ let read_line_into (self : t) ~buf : unit =
)
done
-(* new stream with maximum size [max_size].
- @param close_rec if true, closing this will also close the input stream
- @param too_big called with read size if the max size is reached *)
-let limit_size_to ~close_rec ~max_size ~too_big (arg : t) : t =
- let size = ref 0 in
- let continue = ref true in
- make ~bs:Bytes.empty
- ~close:(fun _ -> if close_rec then arg.close ())
- ~fill:(fun res ->
- if res.len = 0 && !continue then (
- arg.fill_buf ();
- res.bs <- arg.bs;
- res.off <- arg.off;
- res.len <- arg.len
- ) else (
- arg.bs <- Bytes.empty;
- arg.off <- 0;
- arg.len <- 0
- ))
- ~consume:(fun res n ->
- size := !size + n;
- if !size > max_size then (
- continue := false;
- too_big !size
- ) else (
- arg.consume n;
- res.off <- res.off + n;
- res.len <- res.len - n
- ))
- ()
(* read exactly [size] bytes from the stream *)
let read_exactly ~close_rec ~size ~too_short (arg : t) : t =
@@ -320,3 +291,4 @@ let output_chunked' ?buf (oc : IO.Output.t) (self : t) : unit =
(* print a stream as a series of chunks *)
let output_chunked ?buf (oc : out_channel) (self : t) : unit =
output_chunked' ?buf (IO.Output.of_out_channel oc) self
+ *)
diff --git a/src/Tiny_httpd_stream.mli b/src/core/stream.mli.tmp
similarity index 98%
rename from src/Tiny_httpd_stream.mli
rename to src/core/stream.mli.tmp
index a5b5636d..5d2facad 100644
--- a/src/Tiny_httpd_stream.mli
+++ b/src/core/stream.mli.tmp
@@ -64,7 +64,7 @@ val close : t -> unit
val empty : t
(** Stream with 0 bytes inside *)
-val of_input : ?buf_size:int -> Tiny_httpd_io.Input.t -> t
+val of_input : ?buf_size:int -> Io.Input.t -> t
(** Make a buffered stream from the given channel.
@since 0.14 *)
diff --git a/src/Tiny_httpd_util.ml b/src/core/util.ml
similarity index 94%
rename from src/Tiny_httpd_util.ml
rename to src/core/util.ml
index 73617702..38d9bbb9 100644
--- a/src/Tiny_httpd_util.ml
+++ b/src/core/util.ml
@@ -76,6 +76,12 @@ let split_on_slash s : _ list =
List.rev !l
let parse_query s : (_ list, string) result =
+ let s =
+ (* skip hash if present *)
+ match String.index_opt s '#' with
+ | Some i -> String.sub s (i + 1) (String.length s - i - 1)
+ | None -> s
+ in
let pairs = ref [] in
let is_sep_ = function
| '&' | ';' -> true
@@ -119,3 +125,5 @@ let show_sockaddr = function
| Unix.ADDR_UNIX f -> f
| Unix.ADDR_INET (inet, port) ->
Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet) port
+
+let is_ipv6_str addr : bool = String.contains addr ':'
diff --git a/src/Tiny_httpd_util.mli b/src/core/util.mli
similarity index 91%
rename from src/Tiny_httpd_util.mli
rename to src/core/util.mli
index ac996855..1e5a20f3 100644
--- a/src/Tiny_httpd_util.mli
+++ b/src/core/util.mli
@@ -38,3 +38,7 @@ val parse_query : string -> ((string * string) list, string) result
val show_sockaddr : Unix.sockaddr -> string
(** Simple printer for socket addresses.
@since NEXT_RELEASE *)
+
+val is_ipv6_str : string -> bool
+(** Is this string potentially an IPV6 address?
+ @since NEXT_RELEASE *)
diff --git a/src/dune b/src/dune
index 74542c39..81f895bd 100644
--- a/src/dune
+++ b/src/dune
@@ -1,30 +1,6 @@
(library
(name tiny_httpd)
(public_name tiny_httpd)
- (private_modules Tiny_httpd_mime_ Tiny_httpd_parse_)
- (libraries threads seq unix
- (select Tiny_httpd_mime_.ml from
- (magic-mime -> Tiny_httpd_mime_.magic.ml)
- ( -> Tiny_httpd_mime_.dummy.ml))
- (select Tiny_httpd_log.ml from
- (logs logs.fmt fmt.tty -> Tiny_httpd_log.logs.ml)
- (-> Tiny_httpd_log.default.ml)))
- (wrapped false))
-
-(rule
- (targets Tiny_httpd_html_.ml)
- (deps
- (:bin ./gen/gentags.exe))
- (action
- (with-stdout-to
- %{targets}
- (run %{bin}))))
-
-(rule
- (targets Tiny_httpd_atomic_.ml)
- (deps
- (:bin ./gen/mkshims.exe))
- (action
- (with-stdout-to
- %{targets}
- (run %{bin}))))
+ (flags :standard -open Tiny_httpd_core)
+ (libraries threads seq unix hmap tiny_httpd.core tiny_httpd.html
+ tiny_httpd.unix))
diff --git a/src/gen/dune b/src/gen/dune
deleted file mode 100644
index 6cd2fd4a..00000000
--- a/src/gen/dune
+++ /dev/null
@@ -1,2 +0,0 @@
-(executables
- (names gentags mkshims))
diff --git a/src/Tiny_httpd_html.ml b/src/html/Tiny_httpd_html.ml
similarity index 87%
rename from src/Tiny_httpd_html.ml
rename to src/html/Tiny_httpd_html.ml
index 61f0416b..af9cf45d 100644
--- a/src/Tiny_httpd_html.ml
+++ b/src/html/Tiny_httpd_html.ml
@@ -6,9 +6,7 @@
@since 0.12
*)
-module IO = Tiny_httpd_io
-
-include Tiny_httpd_html_
+include Html_
(** @inline *)
(** Write an HTML element to this output.
@@ -16,7 +14,7 @@ include Tiny_httpd_html_
be a "html" tag.
@since 0.14
*)
-let to_output ?(top = false) (self : elt) (out : IO.Output.t) : unit =
+let to_output ?(top = false) (self : elt) (out : #IO.Output.t) : unit =
let out = Out.create_of_out out in
if top then Out.add_string out "\n";
self out;
@@ -56,10 +54,10 @@ let to_out_channel_top = to_output ~top:true
@param top if true, add a DOCTYPE. See {!to_out_channel}.
@since 0.14 *)
let to_writer ?top (self : elt) : IO.Writer.t =
- let write oc = to_output ?top self oc in
+ let write (oc : #IO.Output.t) = to_output ?top self oc in
IO.Writer.make ~write ()
(** Convert a HTML element to a stream. This might just convert
it to a string first, do not assume it to be more efficient. *)
-let to_stream (self : elt) : Tiny_httpd_stream.t =
- Tiny_httpd_stream.of_string @@ to_string self
+let[@inline] to_stream (self : elt) : IO.Input.t =
+ IO.Input.of_string @@ to_string self
diff --git a/src/html/dune b/src/html/dune
new file mode 100644
index 00000000..64386122
--- /dev/null
+++ b/src/html/dune
@@ -0,0 +1,16 @@
+
+
+(library
+ (name tiny_httpd_html)
+ (public_name tiny_httpd.html)
+ (flags :standard -open Tiny_httpd_core)
+ (libraries seq tiny_httpd.core))
+
+(rule
+ (targets html_.ml)
+ (deps
+ (:bin ./gen/gentags.exe))
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin}))))
diff --git a/src/html/gen/dune b/src/html/gen/dune
new file mode 100644
index 00000000..3acc658b
--- /dev/null
+++ b/src/html/gen/dune
@@ -0,0 +1,2 @@
+(executables
+ (names gentags))
diff --git a/src/gen/gentags.ml b/src/html/gen/gentags.ml
similarity index 99%
rename from src/gen/gentags.ml
rename to src/html/gen/gentags.ml
index c23bcfbc..2736b796 100644
--- a/src/gen/gentags.ml
+++ b/src/html/gen/gentags.ml
@@ -294,14 +294,13 @@ let prelude =
module Out : sig
type t
val create_of_buffer : Buffer.t -> t
- val create_of_out: Tiny_httpd_io.Output.t -> t
+ val create_of_out: IO.Output.t -> t
val flush : t -> unit
val add_char : t -> char -> unit
val add_string : t -> string -> unit
val add_format_nl : t -> unit
val with_no_format_nl : t -> (unit -> 'a) -> 'a
end = struct
- module IO = Tiny_httpd_io
type t = {
out: IO.Output.t;
mutable fmt_nl: bool; (* if true, we print [\n] around tags to format the html *)
diff --git a/src/prometheus/common_.ml b/src/prometheus/common_.ml
deleted file mode 100644
index bb70b2d7..00000000
--- a/src/prometheus/common_.ml
+++ /dev/null
@@ -1,3 +0,0 @@
-module A = Tiny_httpd_atomic_
-
-let spf = Printf.sprintf
diff --git a/src/prometheus/common_p_.ml b/src/prometheus/common_p_.ml
new file mode 100644
index 00000000..812670ab
--- /dev/null
+++ b/src/prometheus/common_p_.ml
@@ -0,0 +1,3 @@
+module A = Tiny_httpd_core.Atomic_
+
+let spf = Printf.sprintf
diff --git a/src/prometheus/dune b/src/prometheus/dune
index 5da724e5..3439a474 100644
--- a/src/prometheus/dune
+++ b/src/prometheus/dune
@@ -4,9 +4,10 @@
(name tiny_httpd_prometheus)
(public_name tiny_httpd.prometheus)
(synopsis "Metrics using prometheus")
- (private_modules common_ time_)
+ (private_modules common_p_ time_)
+ (flags :standard -open Tiny_httpd_core)
(libraries
- tiny_httpd unix
+ tiny_httpd.core unix
(select time_.ml from
(mtime mtime.clock.os -> time_.mtime.ml)
(-> time_.default.ml))))
diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index 325018a8..b3ec4e39 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -2,7 +2,7 @@
https://prometheus.io/docs/instrumenting/exposition_formats/#text-based-format
*)
-open Common_
+open Common_p_
let bpf = Printf.bprintf
@@ -175,9 +175,7 @@ end
let global = Registry.create ()
-module H = Tiny_httpd
-
-let http_middleware (reg : Registry.t) : H.Middleware.t =
+let http_middleware (reg : Registry.t) : Server.Middleware.t =
let c_req =
Counter.create reg "tiny_httpd_requests" ~descr:"number of HTTP requests"
in
@@ -189,11 +187,11 @@ let http_middleware (reg : Registry.t) : H.Middleware.t =
~buckets:[ 0.001; 0.01; 0.1; 0.5; 1.; 5.; 10. ]
in
- fun h : H.Middleware.handler ->
+ fun h : Server.Middleware.handler ->
fun req ~resp : unit ->
let start = Time_.now_us () in
Counter.incr c_req;
- h req ~resp:(fun (response : H.Response.t) ->
+ h req ~resp:(fun (response : Response.t) ->
let code = response.code in
let elapsed_us = Time_.now_us () -. start in
@@ -203,13 +201,14 @@ let http_middleware (reg : Registry.t) : H.Middleware.t =
if code < 200 || code >= 400 then Counter.incr c_err;
resp response)
-let add_route_to_server (server : H.t) (reg : registry) : unit =
- H.add_route_handler server H.Route.(exact "metrics" @/ return) @@ fun _req ->
+let add_route_to_server (server : Server.t) (reg : registry) : unit =
+ Server.add_route_handler server Route.(exact "metrics" @/ return)
+ @@ fun _req ->
let str = Registry.emit_str reg in
- H.Response.make_string @@ Ok str
+ Response.make_string @@ Ok str
-let instrument_server (server : H.t) reg : unit =
- H.add_middleware ~stage:(`Stage 1) server (http_middleware reg);
+let instrument_server (server : Server.t) reg : unit =
+ Server.add_middleware ~stage:(`Stage 1) server (http_middleware reg);
add_route_to_server server reg
module GC_metrics = struct
diff --git a/src/prometheus/tiny_httpd_prometheus.mli b/src/prometheus/tiny_httpd_prometheus.mli
index b634943d..dfac868a 100644
--- a/src/prometheus/tiny_httpd_prometheus.mli
+++ b/src/prometheus/tiny_httpd_prometheus.mli
@@ -77,13 +77,13 @@ end
end
*)
-val http_middleware : Registry.t -> Tiny_httpd.Middleware.t
+val http_middleware : Registry.t -> Server.Middleware.t
(** Middleware to get basic metrics about HTTP requests *)
-val add_route_to_server : Tiny_httpd.t -> Registry.t -> unit
+val add_route_to_server : Server.t -> Registry.t -> unit
(** Add a "/metrics" route to the server *)
-val instrument_server : Tiny_httpd.t -> Registry.t -> unit
+val instrument_server : Server.t -> Registry.t -> unit
(** Add middleware and route *)
module GC_metrics : sig
diff --git a/src/Tiny_httpd_dir.ml b/src/unix/dir.ml
similarity index 86%
rename from src/Tiny_httpd_dir.ml
rename to src/unix/dir.ml
index c619c217..0035849c 100644
--- a/src/Tiny_httpd_dir.ml
+++ b/src/unix/dir.ml
@@ -1,7 +1,7 @@
-module S = Tiny_httpd_server
-module U = Tiny_httpd_util
+module S = Server
+module U = Util
module Html = Tiny_httpd_html
-module Log = Tiny_httpd_log
+module Log = Log
type dir_behavior = Index | Lists | Index_or_lists | Forbidden
type hidden = unit
@@ -78,7 +78,7 @@ module type VFS = sig
val list_dir : string -> string array
val delete : string -> unit
val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
- val read_file_content : string -> Tiny_httpd_stream.t
+ val read_file_content : string -> IO.Input.t
val file_size : string -> int option
val file_mtime : string -> float option
end
@@ -99,7 +99,8 @@ let vfs_of_dir (top : string) : vfs =
| { st_kind = Unix.S_REG; _ } ->
let ic = Unix.(openfile fpath [ O_RDONLY ] 0) in
let closed = ref false in
- Tiny_httpd_stream.of_fd_close_noerr ~closed ic
+ let buf = IO.Slice.create 4096 in
+ IO.Input.of_unix_fd ~buf ~close_noerr:true ~closed ic
| _ -> failwith (Printf.sprintf "not a regular file: %S" f)
let create f =
@@ -216,51 +217,52 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
: unit =
let route () =
if prefix = "" then
- S.Route.rest_of_path_urlencoded
+ Route.rest_of_path_urlencoded
else
- S.Route.exact_path prefix S.Route.rest_of_path_urlencoded
+ Route.exact_path prefix Route.rest_of_path_urlencoded
in
if config.delete then
S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req ->
if contains_dot_dot path then
- S.Response.fail_raise ~code:403 "invalid path in delete"
+ Response.fail_raise ~code:403 "invalid path in delete"
else
- S.Response.make_string
+ Response.make_string
(try
VFS.delete path;
Ok "file deleted successfully"
with e -> Error (500, Printexc.to_string e)))
else
S.add_route_handler server ~meth:`DELETE (route ()) (fun _ _ ->
- S.Response.make_raw ~code:405 "delete not allowed");
+ Response.make_raw ~code:405 "delete not allowed");
if config.upload then
S.add_route_handler_stream server ~meth:`PUT (route ())
~accept:(fun req ->
- match S.Request.get_header_int req "Content-Length" with
+ match Request.get_header_int req "Content-Length" with
| Some n when n > config.max_upload_size ->
Error
(403, "max upload size is " ^ string_of_int config.max_upload_size)
- | Some _ when contains_dot_dot req.S.Request.path ->
+ | Some _ when contains_dot_dot req.Request.path ->
Error (403, "invalid path (contains '..')")
| _ -> Ok ())
(fun path req ->
let write, close =
try VFS.create path
with e ->
- S.Response.fail_raise ~code:403 "cannot upload to %S: %s" path
+ Response.fail_raise ~code:403 "cannot upload to %S: %s" path
(Printexc.to_string e)
in
let req =
- S.Request.limit_body_size ~max_size:config.max_upload_size req
+ Request.limit_body_size ~bytes:(Bytes.create 4096)
+ ~max_size:config.max_upload_size req
in
- Tiny_httpd_stream.iter write req.S.Request.body;
+ IO.Input.iter write req.body;
close ();
Log.debug (fun k -> k "dir: done uploading file to %S" path);
- S.Response.make_raw ~code:201 "upload successful")
+ Response.make_raw ~code:201 "upload successful")
else
S.add_route_handler server ~meth:`PUT (route ()) (fun _ _ ->
- S.Response.make_raw ~code:405 "upload not allowed");
+ Response.make_raw ~code:405 "upload not allowed");
if config.download then
S.add_route_handler server ~meth:`GET (route ()) (fun path req ->
@@ -268,19 +270,18 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
let mtime =
lazy
(match VFS.file_mtime path with
- | None -> S.Response.fail_raise ~code:403 "Cannot access file"
+ | None -> Response.fail_raise ~code:403 "Cannot access file"
| Some t -> Printf.sprintf "mtime: %.4f" t)
in
if contains_dot_dot path then
- S.Response.fail ~code:403 "Path is forbidden"
+ Response.fail ~code:403 "Path is forbidden"
else if not (VFS.contains path) then
- S.Response.fail ~code:404 "File not found"
- else if
- S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
+ Response.fail ~code:404 "File not found"
+ else if Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
then (
Log.debug (fun k ->
k "dir: cached object %S (etag: %S)" path (Lazy.force mtime));
- S.Response.make_raw ~code:304 ""
+ Response.make_raw ~code:304 ""
) else if VFS.is_directory path then (
Log.debug (fun k -> k "dir: list dir %S (topdir %S)" path VFS.descr);
let parent = Filename.(dirname path) in
@@ -295,33 +296,36 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
(* redirect using path, not full path *)
let new_path = "/" // prefix // path // "index.html" in
Log.debug (fun k -> k "dir: redirect to `%s`" new_path);
- S.Response.make_void ~code:301 ()
- ~headers:S.Headers.(empty |> set "location" new_path)
+ Response.make_void ~code:301 ()
+ ~headers:Headers.(empty |> set "location" new_path)
| Lists | Index_or_lists ->
let body =
html_list_dir ~prefix vfs path ~parent |> Html.to_string_top
in
- S.Response.make_string
+ Response.make_string
~headers:[ header_html; "ETag", Lazy.force mtime ]
(Ok body)
| Forbidden | Index ->
- S.Response.make_raw ~code:405 "listing dir not allowed"
+ Response.make_raw ~code:405 "listing dir not allowed"
) else (
try
let mime_type =
- if Filename.extension path = ".css" then
+ (* FIXME: handle .html specially *)
+ if Filename.extension path = ".html" then
+ [ "Content-Type", "text/html" ]
+ else if Filename.extension path = ".css" then
[ "Content-Type", "text/css" ]
else if Filename.extension path = ".js" then
[ "Content-Type", "text/javascript" ]
else if on_fs then (
(* call "file" util *)
- let ty = Tiny_httpd_mime_.mime_of_path (top // path) in
+ let ty = Mime_.mime_of_path (top // path) in
[ "content-type", ty ]
) else
[]
in
let stream = VFS.read_file_content path in
- S.Response.make_raw_stream
+ Response.make_raw_stream
~headers:(mime_type @ [ "Etag", Lazy.force mtime ])
~code:200 stream
with e ->
@@ -330,11 +334,11 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
Log.error (fun k ->
k "dir.get failed: %s@.%s" msg
(Printexc.raw_backtrace_to_string bt));
- S.Response.fail ~code:500 "error while reading file: %s" msg
+ Response.fail ~code:500 "error while reading file: %s" msg
))
else
S.add_route_handler server ~meth:`GET (route ()) (fun _ _ ->
- S.Response.make_raw ~code:405 "download not allowed");
+ Response.make_raw ~code:405 "download not allowed");
()
let add_vfs ~config ~vfs ~prefix server : unit =
@@ -437,7 +441,7 @@ module Embedded_fs = struct
let read_file_content p =
match find_ self p with
- | Some (File { content; _ }) -> Tiny_httpd_stream.of_string content
+ | Some (File { content; _ }) -> IO.Input.of_string content
| _ -> failwith (Printf.sprintf "no such file: %S" p)
let list_dir p =
diff --git a/src/Tiny_httpd_dir.mli b/src/unix/dir.mli
similarity index 94%
rename from src/Tiny_httpd_dir.mli
rename to src/unix/dir.mli
index 9590bd60..b07029f9 100644
--- a/src/Tiny_httpd_dir.mli
+++ b/src/unix/dir.mli
@@ -60,7 +60,7 @@ val config :
@since 0.12 *)
val add_dir_path :
- config:config -> dir:string -> prefix:string -> Tiny_httpd_server.t -> unit
+ config:config -> dir:string -> prefix:string -> Server.t -> unit
(** [add_dirpath ~config ~dir ~prefix server] adds route handle to the
[server] to serve static files in [dir] when url starts with [prefix],
using the given configuration [config]. *)
@@ -91,7 +91,7 @@ module type VFS = sig
val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
(** Create a file and obtain a pair [write, close] *)
- val read_file_content : string -> Tiny_httpd_stream.t
+ val read_file_content : string -> IO.Input.t
(** Read content of a file *)
val file_size : string -> int option
@@ -108,11 +108,7 @@ val vfs_of_dir : string -> (module VFS)
*)
val add_vfs :
- config:config ->
- vfs:(module VFS) ->
- prefix:string ->
- Tiny_httpd_server.t ->
- unit
+ config:config -> vfs:(module VFS) -> prefix:string -> Server.t -> unit
(** Similar to {!add_dir_path} but using a virtual file system instead.
@since 0.12
*)
diff --git a/src/unix/dune b/src/unix/dune
new file mode 100644
index 00000000..b10ee59e
--- /dev/null
+++ b/src/unix/dune
@@ -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))
+ ))
diff --git a/src/Tiny_httpd_mime_.dummy.ml b/src/unix/mime_.dummy.ml
similarity index 100%
rename from src/Tiny_httpd_mime_.dummy.ml
rename to src/unix/mime_.dummy.ml
diff --git a/src/Tiny_httpd_mime_.magic.ml b/src/unix/mime_.magic.ml
similarity index 100%
rename from src/Tiny_httpd_mime_.magic.ml
rename to src/unix/mime_.magic.ml
diff --git a/src/Tiny_httpd_mime_.mli b/src/unix/mime_.mli
similarity index 100%
rename from src/Tiny_httpd_mime_.mli
rename to src/unix/mime_.mli
diff --git a/src/unix/sem.ml b/src/unix/sem.ml
new file mode 100644
index 00000000..83159589
--- /dev/null
+++ b/src/unix/sem.ml
@@ -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
diff --git a/src/unix/tiny_httpd_unix.ml b/src/unix/tiny_httpd_unix.ml
new file mode 100644
index 00000000..f1de3936
--- /dev/null
+++ b/src/unix/tiny_httpd_unix.ml
@@ -0,0 +1,155 @@
+module Dir = Dir
+module Sem = Sem
+
+module Unix_tcp_server_ = struct
+ let get_addr_ sock =
+ match Unix.getsockname sock with
+ | Unix.ADDR_INET (addr, port) -> addr, port
+ | _ -> invalid_arg "httpd: address is not INET"
+
+ type t = {
+ addr: string;
+ port: int;
+ buf_pool: Buf.t Pool.t;
+ slice_pool: IO.Slice.t Pool.t;
+ max_connections: int;
+ sem_max_connections: Sem.t;
+ (** semaphore to restrict the number of active concurrent connections *)
+ mutable sock: Unix.file_descr option; (** Socket *)
+ new_thread: (unit -> unit) -> unit;
+ timeout: float;
+ masksigpipe: bool;
+ mutable running: bool; (* TODO: use an atomic? *)
+ }
+
+ let shutdown_silent_ fd =
+ try Unix.shutdown fd Unix.SHUTDOWN_ALL with _ -> ()
+
+ let close_silent_ fd = try Unix.close fd with _ -> ()
+
+ let to_tcp_server (self : t) : IO.TCP_server.builder =
+ {
+ IO.TCP_server.serve =
+ (fun ~after_init ~handle () : unit ->
+ if self.masksigpipe then
+ ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list);
+ let sock, should_bind =
+ match self.sock with
+ | Some s ->
+ ( s,
+ false
+ (* Because we're getting a socket from the caller (e.g. systemd) *)
+ )
+ | None ->
+ ( Unix.socket
+ (if Util.is_ipv6_str self.addr then
+ Unix.PF_INET6
+ else
+ Unix.PF_INET)
+ Unix.SOCK_STREAM 0,
+ true (* Because we're creating the socket ourselves *) )
+ in
+ Unix.clear_nonblock sock;
+ Unix.setsockopt_optint sock Unix.SO_LINGER None;
+ if should_bind then (
+ let inet_addr = Unix.inet_addr_of_string self.addr in
+ Unix.setsockopt sock Unix.SO_REUSEADDR true;
+ Unix.bind sock (Unix.ADDR_INET (inet_addr, self.port));
+ let n_listen = 2 * self.max_connections in
+ Unix.listen sock n_listen
+ );
+
+ self.sock <- Some sock;
+
+ let tcp_server =
+ {
+ IO.TCP_server.stop = (fun () -> self.running <- false);
+ running = (fun () -> self.running);
+ active_connections =
+ (fun () -> Sem.num_acquired self.sem_max_connections - 1);
+ endpoint =
+ (fun () ->
+ let addr, port = get_addr_ sock in
+ Unix.string_of_inet_addr addr, port);
+ }
+ in
+ after_init tcp_server;
+
+ (* how to handle a single client *)
+ let handle_client_unix_ (client_sock : Unix.file_descr)
+ (client_addr : Unix.sockaddr) : unit =
+ Log.debug (fun k ->
+ k "t[%d]: serving new client on %s"
+ (Thread.id @@ Thread.self ())
+ (Util.show_sockaddr client_addr));
+
+ if self.masksigpipe then
+ ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list);
+ Unix.set_nonblock client_sock;
+ Unix.setsockopt client_sock Unix.TCP_NODELAY true;
+ Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout);
+ Unix.(setsockopt_float client_sock SO_SNDTIMEO self.timeout);
+
+ Pool.with_resource self.slice_pool @@ fun ic_buf ->
+ Pool.with_resource self.slice_pool @@ fun oc_buf ->
+ let closed = ref false in
+
+ let oc =
+ new IO.Output.of_unix_fd
+ ~close_noerr:true ~closed ~buf:oc_buf client_sock
+ in
+ let ic =
+ IO.Input.of_unix_fd ~close_noerr:true ~closed ~buf:ic_buf
+ client_sock
+ in
+ handle.handle ~client_addr ic oc
+ in
+
+ Unix.set_nonblock sock;
+ while self.running do
+ match Unix.accept sock with
+ | client_sock, client_addr ->
+ (* limit concurrency *)
+ Sem.acquire 1 self.sem_max_connections;
+ (* Block INT/HUP while cloning to avoid children handling them.
+ When thread gets them, our Unix.accept raises neatly. *)
+ ignore Unix.(sigprocmask SIG_BLOCK Sys.[ sigint; sighup ]);
+ self.new_thread (fun () ->
+ try
+ handle_client_unix_ client_sock client_addr;
+ Log.debug (fun k ->
+ k "t[%d]: done with client on %s, exiting"
+ (Thread.id @@ Thread.self ())
+ @@ Util.show_sockaddr client_addr);
+ shutdown_silent_ client_sock;
+ close_silent_ client_sock;
+ Sem.release 1 self.sem_max_connections
+ with e ->
+ let bt = Printexc.get_raw_backtrace () in
+ shutdown_silent_ client_sock;
+ close_silent_ client_sock;
+ Sem.release 1 self.sem_max_connections;
+ Log.error (fun k ->
+ k
+ "@[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
diff --git a/src/ws/common_.ml b/src/ws/common_ws_.ml
similarity index 100%
rename from src/ws/common_.ml
rename to src/ws/common_ws_.ml
diff --git a/src/ws/dune b/src/ws/dune
index f2aab877..307cd559 100644
--- a/src/ws/dune
+++ b/src/ws/dune
@@ -3,9 +3,10 @@
(name tiny_httpd_ws)
(public_name tiny_httpd.ws)
(synopsis "Websockets for tiny_httpd")
- (private_modules common_ utils_)
+ (private_modules common_ws_ utils_)
+ (flags :standard -open Tiny_httpd_core)
(foreign_stubs
(language c)
(names tiny_httpd_ws_stubs)
(flags :standard -std=c99 -fPIC -O2))
- (libraries tiny_httpd threads))
+ (libraries tiny_httpd.core threads))
diff --git a/src/ws/tiny_httpd_ws.ml b/src/ws/tiny_httpd_ws.ml
index 80867d95..3917ef0e 100644
--- a/src/ws/tiny_httpd_ws.ml
+++ b/src/ws/tiny_httpd_ws.ml
@@ -1,7 +1,4 @@
-open Common_
-open Tiny_httpd_server
-module Log = Tiny_httpd_log
-module IO = Tiny_httpd_io
+open Common_ws_
type handler = Unix.sockaddr -> IO.Input.t -> IO.Output.t -> unit
@@ -382,21 +379,23 @@ let upgrade ic oc : _ * _ =
let writer = Writer.create ~oc () in
let reader = Reader.create ~ic ~writer () in
let ws_ic : IO.Input.t =
- {
- input = (fun buf i len -> Reader.read reader buf i len);
- close = (fun () -> Reader.close reader);
- }
+ object
+ inherit IO.Input.t_from_refill ~bytes:(Bytes.create 4_096) ()
+
+ method private refill (slice : IO.Slice.t) =
+ slice.off <- 0;
+ slice.len <- Reader.read reader slice.bytes 0 (Bytes.length slice.bytes)
+
+ method close () = Reader.close reader
+ end
in
let ws_oc : IO.Output.t =
- {
- flush =
- (fun () ->
- Writer.flush writer;
- IO.Output.flush oc);
- output_char = Writer.output_char writer;
- output = Writer.output writer;
- close = (fun () -> Writer.close writer);
- }
+ object
+ method close () = Writer.close writer
+ method flush () = Writer.flush writer
+ method output bs i len = Writer.output writer bs i len
+ method output_char c = Writer.output_char writer c
+ end
in
ws_ic, ws_oc
@@ -404,7 +403,7 @@ let upgrade ic oc : _ * _ =
module Make_upgrade_handler (X : sig
val accept_ws_protocol : string -> bool
val handler : handler
-end) : UPGRADE_HANDLER = struct
+end) : Server.UPGRADE_HANDLER = struct
type handshake_state = unit
let name = "websocket"
@@ -454,10 +453,10 @@ end) : UPGRADE_HANDLER = struct
end
let add_route_handler ?accept ?(accept_ws_protocol = fun _ -> true)
- (server : Tiny_httpd_server.t) route (f : handler) : unit =
+ (server : Server.t) route (f : handler) : unit =
let module M = Make_upgrade_handler (struct
let handler = f
let accept_ws_protocol = accept_ws_protocol
end) in
- let up : upgrade_handler = (module M) in
- Tiny_httpd_server.add_upgrade_handler ?accept server route up
+ let up : Server.upgrade_handler = (module M) in
+ Server.add_upgrade_handler ?accept server route up
diff --git a/src/ws/tiny_httpd_ws.mli b/src/ws/tiny_httpd_ws.mli
index 44f48e9d..2bd30f70 100644
--- a/src/ws/tiny_httpd_ws.mli
+++ b/src/ws/tiny_httpd_ws.mli
@@ -4,9 +4,6 @@
for a websocket server. It has no additional dependencies.
*)
-open Tiny_httpd_server
-module IO = Tiny_httpd_io
-
type handler = Unix.sockaddr -> IO.Input.t -> IO.Output.t -> unit
(** Websocket handler *)
@@ -16,8 +13,8 @@ val upgrade : IO.Input.t -> IO.Output.t -> IO.Input.t * IO.Output.t
val add_route_handler :
?accept:(unit Request.t -> (unit, int * string) result) ->
?accept_ws_protocol:(string -> bool) ->
- Tiny_httpd_server.t ->
- (upgrade_handler, upgrade_handler) Route.t ->
+ Server.t ->
+ (Server.upgrade_handler, Server.upgrade_handler) Route.t ->
handler ->
unit
(** Add a route handler for a websocket endpoint.
diff --git a/tests/unit/dune b/tests/unit/dune
index c6944d20..7be0c4d9 100644
--- a/tests/unit/dune
+++ b/tests/unit/dune
@@ -2,4 +2,4 @@
(tests
(names t_util t_buf t_server)
(package tiny_httpd)
- (libraries tiny_httpd qcheck-core qcheck-core.runner test_util))
+ (libraries tiny_httpd.core qcheck-core qcheck-core.runner test_util))
diff --git a/tests/unit/t_buf.ml b/tests/unit/t_buf.ml
index 9ee0f685..68e0d20d 100644
--- a/tests/unit/t_buf.ml
+++ b/tests/unit/t_buf.ml
@@ -1,5 +1,5 @@
open Test_util
-open Tiny_httpd_buf
+open Tiny_httpd_core.Buf
let spf = Printf.sprintf
diff --git a/tests/unit/t_server.ml b/tests/unit/t_server.ml
index 56dd77ff..01b82eac 100644
--- a/tests/unit/t_server.ml
+++ b/tests/unit/t_server.ml
@@ -1,5 +1,5 @@
open Test_util
-open Tiny_httpd_server
+open Tiny_httpd_core
let () =
let q =
@@ -9,16 +9,20 @@ let () =
\r\n\
salutationsSOMEJUNK"
in
- let str = Tiny_httpd.Byte_stream.of_string q in
+ let str = IO.Input.of_string q in
let client_addr = Unix.(ADDR_INET (inet_addr_loopback, 1024)) in
- let r = Request.Internal_.parse_req_start ~client_addr ~get_time_s:(fun _ -> 0.) str in
+ let r =
+ Request.Private_.parse_req_start_exn ~client_addr ~buf:(Buf.create ())
+ ~get_time_s:(fun _ -> 0.)
+ str
+ in
match r with
| None -> failwith "should parse"
| Some req ->
- assert_eq (Some "coucou") (Headers.get "Host" req.Request.headers);
- assert_eq (Some "coucou") (Headers.get "host" req.Request.headers);
- assert_eq (Some "11") (Headers.get "content-length" req.Request.headers);
- assert_eq "hello" req.Request.path;
- let req = Request.Internal_.parse_body req str |> Request.read_body_full in
- assert_eq ~to_string:(fun s -> s) "salutations" req.Request.body;
+ assert_eq (Some "coucou") (Headers.get "Host" req.headers);
+ assert_eq (Some "coucou") (Headers.get "host" req.headers);
+ assert_eq (Some "11") (Headers.get "content-length" req.headers);
+ assert_eq "hello" req.path;
+ let req = Request.Private_.parse_body req str |> Request.read_body_full in
+ assert_eq ~to_string:(fun s -> s) "salutations" req.body;
()
diff --git a/tests/unit/t_util.ml b/tests/unit/t_util.ml
index 3ae913a4..db3c6758 100644
--- a/tests/unit/t_util.ml
+++ b/tests/unit/t_util.ml
@@ -1,33 +1,36 @@
open Test_util
-open Tiny_httpd_util
+open Tiny_httpd_core
+module U = Util
-let () = assert_eq "hello%20world" (percent_encode "hello world")
-let () = assert_eq "%23%25^%24%40^%40" (percent_encode "#%^$@^@")
+let () = assert_eq "hello%20world" (U.percent_encode "hello world")
+let () = assert_eq "%23%25^%24%40^%40" (U.percent_encode "#%^$@^@")
let () =
assert_eq "a%20ohm%2B5235%25%26%40%23%20---%20_"
- (percent_encode "a ohm+5235%&@# --- _")
+ (U.percent_encode "a ohm+5235%&@# --- _")
-let () = assert_eq (Some "?") (percent_decode @@ percent_encode "?")
+let () = assert_eq (Some "?") (U.percent_decode @@ U.percent_encode "?")
let () =
add_qcheck
@@ QCheck.Test.make ~count:1_000 ~long_factor:20 Q.string (fun s ->
String.iter (fun c -> Q.assume @@ is_ascii_char c) s;
- match percent_decode (percent_encode s) with
+ match U.percent_decode (U.percent_encode s) with
| Some s' -> s = s'
| None -> Q.Test.fail_report "invalid percent encoding")
-let () = assert_eq [ "a"; "b" ] (split_on_slash "/a/b")
-let () = assert_eq [ "coucou"; "lol" ] (split_on_slash "/coucou/lol")
-let () = assert_eq [ "a"; "b"; "c" ] (split_on_slash "/a/b//c/")
-let () = assert_eq [ "a"; "b" ] (split_on_slash "//a/b/")
-let () = assert_eq [ "a" ] (split_on_slash "/a//")
-let () = assert_eq [] (split_on_slash "/")
-let () = assert_eq [] (split_on_slash "//")
+let () = assert_eq [ "a"; "b" ] (U.split_on_slash "/a/b")
+let () = assert_eq [ "coucou"; "lol" ] (U.split_on_slash "/coucou/lol")
+let () = assert_eq [ "a"; "b"; "c" ] (U.split_on_slash "/a/b//c/")
+let () = assert_eq [ "a"; "b" ] (U.split_on_slash "//a/b/")
+let () = assert_eq [ "a" ] (U.split_on_slash "/a//")
+let () = assert_eq [] (U.split_on_slash "/")
+let () = assert_eq [] (U.split_on_slash "//")
let () =
- assert_eq ~cmp:eq_sorted (Ok [ "a", "b"; "c", "d" ]) (parse_query "a=b&c=d")
+ assert_eq ~cmp:eq_sorted (Ok [ "a", "b"; "c", "d" ]) (U.parse_query "a=b&c=d")
+
+let () = assert_eq (Ok [ "foo", "bar" ]) (U.parse_query "yolo#foo=bar")
let () =
add_qcheck
@@ -43,9 +46,9 @@ let () =
let s =
String.concat "&"
(List.map
- (fun (x, y) -> percent_encode x ^ "=" ^ percent_encode y)
+ (fun (x, y) -> U.percent_encode x ^ "=" ^ U.percent_encode y)
l)
in
- eq_sorted (Ok l) (parse_query s))
+ eq_sorted (Ok l) (U.parse_query s))
let () = run_qcheck_and_exit ()
diff --git a/tests/unit/util/dune b/tests/unit/util/dune
index fb97b15e..e2790663 100644
--- a/tests/unit/util/dune
+++ b/tests/unit/util/dune
@@ -2,4 +2,4 @@
(library
(name test_util)
(modules test_util)
- (libraries qcheck-core qcheck-core.runner))
+ (libraries logs qcheck-core qcheck-core.runner))
diff --git a/tests/unit/util/test_util.ml b/tests/unit/util/test_util.ml
index ae225b00..cd9c3dc5 100644
--- a/tests/unit/util/test_util.ml
+++ b/tests/unit/util/test_util.ml
@@ -29,3 +29,7 @@ let add_qcheck f = qchecks := f :: !qchecks
let run_qcheck_and_exit () : 'a =
exit @@ QCheck_base_runner.run_tests ~colors:false !qchecks
+
+let setup_logs_debug () =
+ Logs.set_reporter @@ Logs.format_reporter ();
+ Logs.set_level ~all:true @@ Some Logs.Debug
diff --git a/tiny_httpd.opam b/tiny_httpd.opam
index a5224f40..c144b511 100644
--- a/tiny_httpd.opam
+++ b/tiny_httpd.opam
@@ -15,6 +15,8 @@ depends: [
"seq"
"base-threads"
"result"
+ "hmap"
+ "iostream" {>= "0.2"}
"ocaml" {>= "4.08"}
"odoc" {with-doc}
"logs" {with-test}
diff --git a/tiny_httpd_camlzip.opam b/tiny_httpd_camlzip.opam
index e8a269f2..e28dde38 100644
--- a/tiny_httpd_camlzip.opam
+++ b/tiny_httpd_camlzip.opam
@@ -11,6 +11,7 @@ depends: [
"dune" {>= "2.9"}
"tiny_httpd" {= version}
"camlzip" {>= "1.06"}
+ "iostream-camlzip"
"logs" {with-test}
"odoc" {with-doc}
]
diff --git a/vendor/iostream b/vendor/iostream
new file mode 160000
index 00000000..668a7c22
--- /dev/null
+++ b/vendor/iostream
@@ -0,0 +1 @@
+Subproject commit 668a7c22c09d21293c9ce3fd8bc66b3080c525d2