From 5f321774e17f71e93f2fee3f637c95a9a2b3c553 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 26 Feb 2024 13:41:55 -0500 Subject: [PATCH 01/20] wip: use Iostream for IOs; add hmap to request; refactor --- src/core/IO.ml | 486 ++++++++++++++++++++++++++++++++++ src/core/buf.ml | 55 ++++ src/core/buf.mli | 42 +++ src/core/common_.ml | 10 + src/core/dune | 21 ++ src/core/gen/dune | 2 + src/core/gen/mkshims.ml | 41 +++ src/core/headers.ml | 70 +++++ src/core/headers.mli | 35 +++ src/core/log.default.ml | 7 + src/core/log.logs.ml | 22 ++ src/core/log.mli | 12 + src/core/meth.ml | 22 ++ src/core/meth.mli | 11 + src/core/mime_.dummy.ml | 1 + src/core/mime_.magic.ml | 1 + src/core/mime_.mli | 2 + src/core/parse_.ml | 77 ++++++ src/core/pool.ml | 51 ++++ src/core/pool.mli | 25 ++ src/core/request.ml | 204 +++++++++++++++ src/core/request.mli | 135 ++++++++++ src/core/response.ml | 162 ++++++++++++ src/core/response.mli | 118 +++++++++ src/core/response_code.ml | 32 +++ src/core/response_code.mli | 20 ++ src/core/route.ml | 93 +++++++ src/core/route.mli | 58 +++++ src/core/server.ml | 515 +++++++++++++++++++++++++++++++++++++ src/core/server.mli | 298 +++++++++++++++++++++ src/core/stream.ml.tmp | 294 +++++++++++++++++++++ src/core/stream.mli.tmp | 159 ++++++++++++ src/core/util.ml | 121 +++++++++ src/core/util.mli | 40 +++ 34 files changed, 3242 insertions(+) create mode 100644 src/core/IO.ml create mode 100644 src/core/buf.ml create mode 100644 src/core/buf.mli create mode 100644 src/core/common_.ml create mode 100644 src/core/dune create mode 100644 src/core/gen/dune create mode 100644 src/core/gen/mkshims.ml create mode 100644 src/core/headers.ml create mode 100644 src/core/headers.mli create mode 100644 src/core/log.default.ml create mode 100644 src/core/log.logs.ml create mode 100644 src/core/log.mli create mode 100644 src/core/meth.ml create mode 100644 src/core/meth.mli create mode 100644 src/core/mime_.dummy.ml create mode 100644 src/core/mime_.magic.ml create mode 100644 src/core/mime_.mli create mode 100644 src/core/parse_.ml create mode 100644 src/core/pool.ml create mode 100644 src/core/pool.mli create mode 100644 src/core/request.ml create mode 100644 src/core/request.mli create mode 100644 src/core/response.ml create mode 100644 src/core/response.mli create mode 100644 src/core/response_code.ml create mode 100644 src/core/response_code.mli create mode 100644 src/core/route.ml create mode 100644 src/core/route.mli create mode 100644 src/core/server.ml create mode 100644 src/core/server.mli create mode 100644 src/core/stream.ml.tmp create mode 100644 src/core/stream.mli.tmp create mode 100644 src/core/util.ml create mode 100644 src/core/util.mli diff --git a/src/core/IO.ml b/src/core/IO.ml new file mode 100644 index 00000000..ba00b6ef --- /dev/null +++ b/src/core/IO.ml @@ -0,0 +1,486 @@ +(** 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_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 (self) + method flush () = + write_buf ~force:true (); + flush self + + method 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 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 ~buf () + + 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 ~buf:slice () + + 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 (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 to_chan oc (self : #t) = + iter + (fun (slice : Slice.t) -> + Stdlib.output oc slice.bytes slice.off slice.len) + self + + let to_chan' (oc : #Iostream.Out_buf.t) (self : #t) : unit = + iter + (fun (slice : Slice.t) -> + Iostream.Out_buf.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 = self#fill_buf () 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 + + (** put [n] bytes from the input into bytes *) + let read_exactly_ ~too_short (self : #t) (bytes : bytes) (n : int) : unit = + assert (Bytes.length bytes >= n); + let offset = ref 0 in + while !offset < n do + 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 + + (** 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 : bytes) (arg : t) : t = + let remaining_size = ref max_size in + let slice = Slice.of_bytes bytes in + + object + inherit Iostream.In_buf.t_from_refill ~buf:slice () + method! close () = if close_rec then close arg + + method private refill slice = + if slice.len = 0 then + if !remaining_size > 0 then ( + let sub = fill_buf arg in + let len = min sub.len !remaining_size in + + Bytes.blit sub.bytes sub.off slice.bytes 0 len; + slice.off <- 0; + slice.len <- len; + Slice.consume sub len + ) + end + + (** 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 : bytes) (arg : t) : t = + let remaining_size = ref size in + let slice = Slice.of_bytes bytes in + + object + inherit Iostream.In_buf.t_from_refill ~buf:slice () + + method! close () = + if !remaining_size > 0 then skip arg !remaining_size; + if close_rec then close arg + + method private refill slice = + if slice.len = 0 then + if !remaining_size > 0 then ( + let sub = fill_buf arg in + let len = min sub.len !remaining_size in + + Bytes.blit sub.bytes sub.off slice.bytes 0 len; + slice.off <- 0; + slice.len <- len; + Slice.consume sub len + ) + end + + let read_chunked ~(buf : Slice.t) ~fail (bs : #t) : t = + let first = ref true in + let line_buf = Buf.create ~size:128 () in + let read_next_chunk_len () : int = + if !first then + first := false + else ( + let line = read_line_using ~buf:line_buf bs in + if String.trim line <> "" then + raise (fail "expected crlf between chunks") + ); + let line = read_line_using ~buf:line_buf bs in + (* parse chunk length, ignore extensions *) + let chunk_size = + if String.trim line = "" then + 0 + else ( + try + let off = ref 0 in + let n = 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 ~buf () + + method private refill (slice : Slice.t) : unit = + if !chunk_size = 0 && not !eof then chunk_size := read_next_chunk_len (); + 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")) + bs slice.bytes to_read; + slice.len <- to_read; + chunk_size := !chunk_size - to_read + ) else + (* stream is finished *) + eof := true + + method! close () = + (* do not close underlying stream *) + eof := true; + () + 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 + + (** 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 } + + 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/core/buf.ml b/src/core/buf.ml new file mode 100644 index 00000000..fcc89933 --- /dev/null +++ b/src/core/buf.ml @@ -0,0 +1,55 @@ +type t = { mutable bytes: bytes; mutable i: int; original: bytes } + +let create ?(size = 4_096) () : t = + let bytes = Bytes.make size ' ' in + { bytes; i = 0; original = bytes } + +let[@inline] size self = self.i +let[@inline] bytes_slice self = self.bytes + +let clear self : unit = + if + Bytes.length self.bytes > 500 * 1_024 + && Bytes.length self.bytes > Bytes.length self.original + then + (* free big buffer *) + self.bytes <- self.original; + self.i <- 0 + +let clear_and_zero self = + clear self; + Bytes.fill self.bytes 0 (Bytes.length self.bytes) '\x00' + +let resize self new_size : unit = + let new_buf = Bytes.make new_size ' ' in + Bytes.blit self.bytes 0 new_buf 0 self.i; + self.bytes <- new_buf + +let add_char self c : unit = + if self.i + 1 >= Bytes.length self.bytes then + resize self (self.i + (self.i / 2) + 10); + Bytes.set self.bytes self.i c; + self.i <- 1 + self.i + +let add_bytes (self : t) s i len : unit = + if self.i + len >= Bytes.length self.bytes then + resize self (self.i + (self.i / 2) + len + 10); + Bytes.blit s i self.bytes self.i len; + self.i <- self.i + len + +let[@inline] add_string self str : unit = + add_bytes self (Bytes.unsafe_of_string str) 0 (String.length str) + +let add_buffer (self : t) (buf : Buffer.t) : unit = + let len = Buffer.length buf in + if self.i + len >= Bytes.length self.bytes then + resize self (self.i + (self.i / 2) + len + 10); + Buffer.blit buf 0 self.bytes self.i len; + self.i <- self.i + len + +let contents (self : t) : string = Bytes.sub_string self.bytes 0 self.i + +let contents_and_clear (self : t) : string = + let x = contents self in + clear self; + x diff --git a/src/core/buf.mli b/src/core/buf.mli new file mode 100644 index 00000000..e5ca90c1 --- /dev/null +++ b/src/core/buf.mli @@ -0,0 +1,42 @@ +(** Simple buffer. + + These buffers are used to avoid allocating too many byte arrays when + processing streams and parsing requests. + + @since 0.12 +*) + +type t + +val size : t -> int +val clear : t -> unit +val create : ?size:int -> unit -> t +val contents : t -> string + +val clear_and_zero : t -> unit +(** Clear the buffer and zero out its storage. + @since 0.15 *) + +val bytes_slice : t -> bytes +(** Access underlying slice of bytes. + @since 0.5 *) + +val contents_and_clear : t -> string +(** Get contents of the buffer and clear it. + @since 0.5 *) + +val add_char : t -> char -> unit +(** Add a single char. + @since 0.14 *) + +val add_bytes : t -> bytes -> int -> int -> unit +(** Append given bytes slice to the buffer. + @since 0.5 *) + +val add_string : t -> string -> unit +(** Add string. + @since 0.14 *) + +val add_buffer : t -> Buffer.t -> unit +(** Append bytes from buffer. + @since 0.14 *) 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..36bcf2d8 --- /dev/null +++ b/src/core/dune @@ -0,0 +1,21 @@ + +(library + (name tiny_httpd_core) + (public_name tiny_httpd.core) + (private_modules mime_ parse_) + (libraries threads seq hmap iostream + (select mime_.ml from + (magic-mime -> mime_.magic.ml) + ( -> mime_.dummy.ml)) + (select log.ml from + (logs -> log.logs.ml) + (-> log.default.ml)))) + +(rule + (targets Tiny_httpd_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/core/gen/mkshims.ml b/src/core/gen/mkshims.ml new file mode 100644 index 00000000..a49f1ab7 --- /dev/null +++ b/src/core/gen/mkshims.ml @@ -0,0 +1,41 @@ +let atomic_before_412 = + {| + type 'a t = {mutable x: 'a} + let[@inline] make x = {x} + let[@inline] get {x} = x + let[@inline] set r x = r.x <- x + let[@inline] exchange r x = + let y = r.x in + r.x <- x; + y + + let[@inline] compare_and_set r seen v = + if r.x == seen then ( + r.x <- v; + true + ) else false + + let[@inline] fetch_and_add r x = + let v = r.x in + r.x <- x + r.x; + v + + let[@inline] incr r = r.x <- 1 + r.x + let[@inline] decr r = r.x <- r.x - 1 + |} + +let atomic_after_412 = {|include Atomic|} + +let write_file file s = + let oc = open_out file in + output_string oc s; + close_out oc + +let () = + let version = Scanf.sscanf Sys.ocaml_version "%d.%d.%s" (fun x y _ -> x, y) in + print_endline + (if version >= (4, 12) then + atomic_after_412 + else + atomic_before_412); + () 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/core/log.default.ml b/src/core/log.default.ml new file mode 100644 index 00000000..5340578b --- /dev/null +++ b/src/core/log.default.ml @@ -0,0 +1,7 @@ +(* default: no logging *) + +let info _ = () +let debug _ = () +let error _ = () +let setup ~debug:_ () = () +let dummy = true diff --git a/src/core/log.logs.ml b/src/core/log.logs.ml new file mode 100644 index 00000000..f2cc8f56 --- /dev/null +++ b/src/core/log.logs.ml @@ -0,0 +1,22 @@ +(* Use Logs *) + +module Log = (val Logs.(src_log @@ Src.create "tiny_httpd")) + +let info k = Log.info (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x)) +let debug k = Log.debug (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x)) +let error k = Log.err (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x)) + +let setup ~debug () = + let mutex = Mutex.create () in + Logs.set_reporter_mutex + ~lock:(fun () -> Mutex.lock mutex) + ~unlock:(fun () -> Mutex.unlock mutex); + Logs.set_reporter @@ Logs.format_reporter (); + Logs.set_level ~all:true + (Some + (if debug then + Logs.Debug + else + Logs.Info)) + +let dummy = false diff --git a/src/core/log.mli b/src/core/log.mli new file mode 100644 index 00000000..5944e125 --- /dev/null +++ b/src/core/log.mli @@ -0,0 +1,12 @@ +(** Logging for tiny_httpd *) + +val info : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit +val debug : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit +val error : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit + +val setup : debug:bool -> unit -> unit +(** Setup and enable logging. This should only ever be used in executables, + not libraries. + @param debug if true, set logging to debug (otherwise info) *) + +val dummy : bool 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/core/mime_.dummy.ml b/src/core/mime_.dummy.ml new file mode 100644 index 00000000..dc944b1c --- /dev/null +++ b/src/core/mime_.dummy.ml @@ -0,0 +1 @@ +let mime_of_path _ = "application/octet-stream" diff --git a/src/core/mime_.magic.ml b/src/core/mime_.magic.ml new file mode 100644 index 00000000..72fcd345 --- /dev/null +++ b/src/core/mime_.magic.ml @@ -0,0 +1 @@ +let mime_of_path s = Magic_mime.lookup s diff --git a/src/core/mime_.mli b/src/core/mime_.mli new file mode 100644 index 00000000..1831c02d --- /dev/null +++ b/src/core/mime_.mli @@ -0,0 +1,2 @@ + +val mime_of_path : string -> string diff --git a/src/core/parse_.ml b/src/core/parse_.ml new file mode 100644 index 00000000..39430889 --- /dev/null +++ b/src/core/parse_.ml @@ -0,0 +1,77 @@ +(** Basic parser for lines *) + +type 'a t = string -> int ref -> 'a + +open struct + let spf = Printf.sprintf +end + +let[@inline] eof s off = !off = String.length s + +let[@inline] skip_space : unit t = + fun s off -> + while !off < String.length s && String.unsafe_get s !off = ' ' do + incr off + done + +let pos_int : int t = + fun s off : int -> + skip_space s off; + let n = ref 0 in + let continue = ref true in + while !off < String.length s && !continue do + match String.unsafe_get s !off with + | '0' .. '9' as c -> n := (!n * 10) + Char.code c - Char.code '0' + | ' ' | '\t' | '\n' -> continue := false + | c -> failwith @@ spf "expected int, got %C" c + done; + !n + +let pos_hex : int t = + fun s off : int -> + skip_space s off; + let n = ref 0 in + let continue = ref true in + while !off < String.length s && !continue do + match String.unsafe_get s !off with + | 'a' .. 'f' as c -> + incr off; + n := (!n * 16) + Char.code c - Char.code 'a' + 10 + | 'A' .. 'F' as c -> + incr off; + n := (!n * 16) + Char.code c - Char.code 'A' + 10 + | '0' .. '9' as c -> + incr off; + n := (!n * 16) + Char.code c - Char.code '0' + | ' ' | '\r' -> continue := false + | c -> failwith @@ spf "expected int, got %C" c + done; + !n + +(** Parse a word without spaces *) +let word : string t = + fun s off -> + skip_space s off; + let start = !off in + let continue = ref true in + while !off < String.length s && !continue do + match String.unsafe_get s !off with + | ' ' | '\r' -> continue := false + | _ -> incr off + done; + if !off = start then failwith "expected word"; + String.sub s start (!off - start) + +let exact str : unit t = + fun s off -> + skip_space s off; + let len = String.length str in + if !off + len > String.length s then + failwith @@ spf "unexpected EOF, expected %S" str; + for i = 0 to len - 1 do + let expected = String.unsafe_get str i in + let c = String.unsafe_get s (!off + i) in + if c <> expected then + failwith @@ spf "expected %S, got %C at position %d" str c i + done; + off := !off + len diff --git a/src/core/pool.ml b/src/core/pool.ml new file mode 100644 index 00000000..1a441944 --- /dev/null +++ b/src/core/pool.ml @@ -0,0 +1,51 @@ +module A = Tiny_httpd_atomic_ + +type 'a list_ = Nil | Cons of int * 'a * 'a list_ + +type 'a t = { + mk_item: unit -> 'a; + clear: 'a -> unit; + max_size: int; (** Max number of items *) + items: 'a list_ A.t; +} + +let create ?(clear = ignore) ~mk_item ?(max_size = 512) () : _ t = + { mk_item; clear; max_size; items = A.make Nil } + +let rec acquire_ self = + match A.get self.items with + | Nil -> self.mk_item () + | Cons (_, x, tl) as l -> + if A.compare_and_set self.items l tl then + x + else + acquire_ self + +let[@inline] size_ = function + | Cons (sz, _, _) -> sz + | Nil -> 0 + +let release_ self x : unit = + let rec loop () = + match A.get self.items with + | Cons (sz, _, _) when sz >= self.max_size -> + (* forget the item *) + () + | l -> + if not (A.compare_and_set self.items l (Cons (size_ l + 1, x, l))) then + loop () + in + + self.clear x; + loop () + +let with_resource (self : _ t) f = + let x = acquire_ self in + try + let res = f x in + release_ self x; + res + with e -> + let bt = Printexc.get_raw_backtrace () in + release_ self x; + Printexc.raise_with_backtrace e bt diff --git a/src/core/pool.mli b/src/core/pool.mli new file mode 100644 index 00000000..a2418e11 --- /dev/null +++ b/src/core/pool.mli @@ -0,0 +1,25 @@ +(** Resource pool. + + This pool is used for buffers. It can be used for other resources + but do note that it assumes resources are still reasonably + cheap to produce and discard, and will never block waiting for + a resource — it's not a good pool for DB connections. + + @since 0.14. *) + +type 'a t +(** Pool of values of type ['a] *) + +val create : + ?clear:('a -> unit) -> mk_item:(unit -> 'a) -> ?max_size:int -> unit -> 'a t +(** Create a new pool. + @param mk_item produce a new item in case the pool is empty + @param max_size maximum number of item in the pool before we start + dropping resources on the floor. This controls resource consumption. + @param clear a function called on items before recycling them. + *) + +val with_resource : 'a t -> ('a -> 'b) -> 'b +(** [with_resource pool f] runs [f x] with [x] a resource; + when [f] fails or returns, [x] is returned to the pool for + future reuse. *) diff --git a/src/core/request.ml b/src/core/request.ml new file mode 100644 index 00000000..1a5c19b7 --- /dev/null +++ b/src/core/request.ml @@ -0,0 +1,204 @@ +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 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 : #IO.Input.t) : IO.Input.t = + Log.debug (fun k -> k "body: start reading chunked stream..."); + IO.Input.read_chunked ~buf ~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 = Bytes.create 4096) (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 ~size ~bytes + +(* 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 + 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 ~buf (req : IO.Input.t t) : IO.Input.t 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 -> + let bytes = Bytes.create 4096 in + read_exactly ~size ~bytes @@ tr_stream req.body + | Some "chunked" -> + (* body sent by chunks *) + let bs : IO.Input.t = read_stream_chunked_ ~buf @@ tr_stream req.body in + if size > 0 then ( + 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 ?buf ?buf_size (self : IO.Input.t t) : string t = + try + let buf = + match buf with + | Some b -> 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 ?(buf = IO.Slice.create 4096) req bs : _ t = + parse_body_ ~tr_stream:(fun s -> s) ~buf { 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..cf4f8368 --- /dev/null +++ b/src/core/request.mli @@ -0,0 +1,135 @@ +(** 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 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. + @param bytes intermediate buffer + @since 0.3 + *) + +val read_body_full : ?buf:Buf.t -> ?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 buf 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 : ?buf:IO.Slice.t -> 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..1bd7af66 --- /dev/null +++ b/src/core/response.ml @@ -0,0 +1,162 @@ +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 + +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 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..610faed5 --- /dev/null +++ b/src/core/response.mli @@ -0,0 +1,118 @@ +(** 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"]. + *) + +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. *) + +(**/**) + +module Private_ : sig + val make_void_force_ : ?headers:Headers.t -> code:int -> unit -> t + val output_ : buf:Buf.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..33bacc1a --- /dev/null +++ b/src/core/server.ml @@ -0,0 +1,515 @@ +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 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: 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 *) + 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 = 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 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 + (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.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 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 ':' + +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 (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) + (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" + (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_ ~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.Private_.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.Private_.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.Private_.output_ ~buf:buf_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 + 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_ ~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.Private_.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.Private_.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.Private_.parse_body + ~buf:(IO.Slice.of_bytes (Buf.bytes_slice buf)) + 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_ ~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.Private_.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/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/core/stream.ml.tmp b/src/core/stream.ml.tmp new file mode 100644 index 00000000..607a4f5f --- /dev/null +++ b/src/core/stream.ml.tmp @@ -0,0 +1,294 @@ +(* +module Buf = Tiny_httpd_buf +module IO = Tiny_httpd_io + +let spf = Printf.sprintf + +type hidden = unit + +type t = { + mutable bs: bytes; + mutable off: int; + mutable len: int; + fill_buf: unit -> unit; + consume: int -> unit; + close: unit -> unit; + _rest: hidden; +} + +let[@inline] close self = self.close () + +let empty = + { + bs = Bytes.empty; + off = 0; + len = 0; + fill_buf = ignore; + consume = ignore; + close = ignore; + _rest = (); + } + +let make ?(bs = Bytes.create @@ (16 * 1024)) ?(close = ignore) ~consume ~fill () + : t = + let rec self = + { + bs; + off = 0; + len = 0; + close = (fun () -> close self); + fill_buf = (fun () -> if self.len = 0 then fill self); + consume = + (fun n -> + assert (n <= self.len); + consume self n); + _rest = (); + } + in + self + +let of_input ?(buf_size = 16 * 1024) (ic : IO.Input.t) : t = + make ~bs:(Bytes.create buf_size) + ~close:(fun _ -> IO.Input.close ic) + ~consume:(fun self n -> + assert (self.len >= n); + self.off <- self.off + n; + self.len <- self.len - n) + ~fill:(fun self -> + if self.len = 0 then ( + self.off <- 0; + self.len <- IO.Input.input ic self.bs 0 (Bytes.length self.bs) + )) + () + +let of_chan_ ?buf_size ic ~close_noerr : t = + let inc = IO.Input.of_in_channel ~close_noerr ic in + of_input ?buf_size inc + +let of_chan ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:false +let of_chan_close_noerr ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:true + +let of_fd_ ?buf_size ~close_noerr ~closed ic : t = + let inc = IO.Input.of_unix_fd ~close_noerr ~closed ic in + of_input ?buf_size inc + +let of_fd ?buf_size ~closed fd : t = + of_fd_ ?buf_size ~closed ~close_noerr:false fd + +let of_fd_close_noerr ?buf_size ~closed fd : t = + of_fd_ ?buf_size ~closed ~close_noerr:true fd + +let iter f (self : t) : unit = + let continue = ref true in + while !continue do + self.fill_buf (); + if self.len = 0 then ( + continue := false; + self.close () + ) else ( + f self.bs self.off self.len; + self.consume self.len + ) + done + +let to_chan (oc : out_channel) (self : t) = iter (output oc) self +let to_chan' (oc : IO.Output.t) (self : t) = iter (IO.Output.output oc) self + +let to_writer (self : t) : Tiny_httpd_io.Writer.t = + { write = (fun oc -> to_chan' oc self) } + +let of_bytes ?(i = 0) ?len (bs : bytes) : t = + (* invariant: !i+!len is constant *) + let len = + match len with + | Some n -> + if n > Bytes.length bs - i then invalid_arg "Byte_stream.of_bytes"; + n + | None -> Bytes.length bs - i + in + let self = + make ~bs ~fill:ignore + ~close:(fun self -> self.len <- 0) + ~consume:(fun self n -> + assert (n >= 0 && n <= self.len); + self.off <- n + self.off; + self.len <- self.len - n) + () + in + self.off <- i; + self.len <- len; + self + +let of_string s : t = of_bytes (Bytes.unsafe_of_string s) + +let with_file ?buf_size file f = + let ic = Unix.(openfile file [ O_RDONLY ] 0) in + try + let x = f (of_fd ?buf_size ~closed:(ref false) ic) in + Unix.close ic; + x + with e -> + Unix.close ic; + raise e + +let read_all ?(buf = Buf.create ()) (self : t) : string = + let continue = ref true in + while !continue do + self.fill_buf (); + if self.len = 0 then + continue := false + else ( + assert (self.len > 0); + Buf.add_bytes buf self.bs self.off self.len; + self.consume self.len + ) + done; + Buf.contents_and_clear buf + +(* put [n] bytes from the input into bytes *) +let read_exactly_ ~too_short (self : t) (bytes : bytes) (n : int) : unit = + assert (Bytes.length bytes >= n); + let offset = ref 0 in + while !offset < n do + self.fill_buf (); + let n_read = min self.len (n - !offset) in + Bytes.blit self.bs self.off bytes !offset n_read; + offset := !offset + n_read; + self.consume n_read; + if n_read = 0 then too_short () + done + +(* read a line into the buffer, after clearing it. *) +let read_line_into (self : t) ~buf : unit = + Buf.clear buf; + let continue = ref true in + while !continue do + self.fill_buf (); + if self.len = 0 then ( + continue := false; + if Buf.size buf = 0 then raise End_of_file + ); + let j = ref self.off in + while !j < self.off + self.len && Bytes.get self.bs !j <> '\n' do + incr j + done; + if !j - self.off < self.len then ( + assert (Bytes.get self.bs !j = '\n'); + (* line without '\n' *) + Buf.add_bytes buf self.bs self.off (!j - self.off); + (* consume line + '\n' *) + self.consume (!j - self.off + 1); + continue := false + ) else ( + Buf.add_bytes buf self.bs self.off self.len; + self.consume self.len + ) + done + + +(* read exactly [size] bytes from the stream *) +let read_exactly ~close_rec ~size ~too_short (arg : t) : t = + if size = 0 then + empty + else ( + let size = ref size in + make ~bs:Bytes.empty + ~fill:(fun res -> + (* must not block on [arg] if we're done *) + if !size = 0 then ( + res.bs <- Bytes.empty; + res.off <- 0; + res.len <- 0 + ) else ( + arg.fill_buf (); + res.bs <- arg.bs; + res.off <- arg.off; + let len = min arg.len !size in + if len = 0 && !size > 0 then too_short !size; + res.len <- len + )) + ~close:(fun _res -> + (* close underlying stream if [close_rec] *) + if close_rec then arg.close (); + size := 0) + ~consume:(fun res n -> + let n = min n !size in + size := !size - n; + arg.consume n; + res.off <- res.off + n; + res.len <- res.len - n) + () + ) + +let read_line ?(buf = Buf.create ()) self : string = + read_line_into self ~buf; + Buf.contents buf + +let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t = + let first = ref true in + let read_next_chunk_len () : int = + if !first then + first := false + else ( + let line = read_line ~buf bs in + if String.trim line <> "" then raise (fail "expected crlf between chunks") + ); + let line = read_line ~buf bs in + (* parse chunk length, ignore extensions *) + let chunk_size = + if String.trim line = "" then + 0 + else ( + try + let off = ref 0 in + let n = Tiny_httpd_parse_.pos_hex line off in + n + with _ -> + raise (fail (spf "cannot read chunk size from line %S" line)) + ) + in + chunk_size + in + let refill = ref true in + let chunk_size = ref 0 in + make + ~bs:(Bytes.create (16 * 4096)) + ~fill:(fun self -> + (* do we need to refill? *) + if self.len = 0 then ( + if !chunk_size = 0 && !refill then chunk_size := read_next_chunk_len (); + self.off <- 0; + self.len <- 0; + if !chunk_size > 0 then ( + (* read the whole chunk, or [Bytes.length bytes] of it *) + let to_read = min !chunk_size (Bytes.length self.bs) in + read_exactly_ + ~too_short:(fun () -> raise (fail "chunk is too short")) + bs self.bs to_read; + self.len <- to_read; + chunk_size := !chunk_size - to_read + ) else + refill := false (* stream is finished *) + )) + ~consume:(fun self n -> + self.off <- self.off + n; + self.len <- self.len - n) + ~close:(fun self -> + (* close this overlay, do not close underlying stream *) + self.len <- 0; + refill := false) + () + +let output_chunked' ?buf (oc : IO.Output.t) (self : t) : unit = + let oc' = IO.Output.chunk_encoding ?buf oc ~close_rec:false in + match to_chan' oc' self with + | () -> IO.Output.close oc' + | exception e -> + let bt = Printexc.get_raw_backtrace () in + IO.Output.close oc'; + Printexc.raise_with_backtrace e bt + +(* print a stream as a series of chunks *) +let output_chunked ?buf (oc : out_channel) (self : t) : unit = + output_chunked' ?buf (IO.Output.of_out_channel oc) self + *) diff --git a/src/core/stream.mli.tmp b/src/core/stream.mli.tmp new file mode 100644 index 00000000..5d2facad --- /dev/null +++ b/src/core/stream.mli.tmp @@ -0,0 +1,159 @@ +(** Byte streams. + + Streams are used to represent a series of bytes that can arrive progressively. + For example, an uploaded file will be sent as a series of chunks. + + These used to live in {!Tiny_httpd} but are now in their own module. + @since 0.12 *) + +type hidden +(** Type used to make {!t} unbuildable via a record literal. Use {!make} instead. *) + +type t = { + mutable bs: bytes; (** The bytes *) + mutable off: int; (** Beginning of valid slice in {!bs} *) + mutable len: int; + (** Length of valid slice in {!bs}. If [len = 0] after + a call to {!fill}, then the stream is finished. *) + fill_buf: unit -> unit; + (** See the current slice of the internal buffer as [bytes, i, len], + where the slice is [bytes[i] .. [bytes[i+len-1]]]. + Can block to refill the buffer if there is currently no content. + If [len=0] then there is no more data. *) + consume: int -> unit; + (** Consume [n] bytes from the buffer. + This should only be called with [n <= len]. *) + close: unit -> unit; (** Close the stream. *) + _rest: hidden; (** Use {!make} to build a stream. *) +} +(** A buffered stream, with a view into the current buffer (or refill if empty), + and a function to consume [n] bytes. + + The point of this type is that it gives the caller access to its internal buffer + ([bs], with the slice [off,len]). This is convenient for things like line + reading where one needs to peek ahead. + + Some core invariant for this type of stream are: + - [off,len] delimits a valid slice in [bs] (indices: [off, off+1, … off+len-1]) + - if [fill_buf()] was just called, then either [len=0] which indicates the end + of stream; or [len>0] and the slice contains some data. + + To actually move forward in the stream, you can call [consume n] + to consume [n] bytes (where [n <= len]). If [len] gets to [0], calling + [fill_buf()] is required, so it can try to obtain a new slice. + + To emulate a classic OCaml reader with a [read: bytes -> int -> int -> int] function, + the simplest is: + + {[ + let read (self:t) buf offset max_len : int = + self.fill_buf(); + let len = min max_len self.len in + if len > 0 then ( + Bytes.blit self.bs self.off buf offset len; + self.consume len; + ); + len + + ]} +*) + +val close : t -> unit +(** Close stream *) + +val empty : t +(** Stream with 0 bytes inside *) + +val of_input : ?buf_size:int -> Io.Input.t -> t +(** Make a buffered stream from the given channel. + @since 0.14 *) + +val of_chan : ?buf_size:int -> in_channel -> t +(** Make a buffered stream from the given channel. *) + +val of_chan_close_noerr : ?buf_size:int -> in_channel -> t +(** Same as {!of_chan} but the [close] method will never fail. *) + +val of_fd : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t +(** Make a buffered stream from the given file descriptor. *) + +val of_fd_close_noerr : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t +(** Same as {!of_fd} but the [close] method will never fail. *) + +val of_bytes : ?i:int -> ?len:int -> bytes -> t +(** A stream that just returns the slice of bytes starting from [i] + and of length [len]. *) + +val of_string : string -> t + +val iter : (bytes -> int -> int -> unit) -> t -> unit +(** Iterate on the chunks of the stream + @since 0.3 *) + +val to_chan : out_channel -> t -> unit +(** Write the stream to the channel. + @since 0.3 *) + +val to_chan' : Tiny_httpd_io.Output.t -> t -> unit +(** Write to the IO channel. + @since 0.14 *) + +val to_writer : t -> Tiny_httpd_io.Writer.t +(** Turn this stream into a writer. + @since 0.14 *) + +val make : + ?bs:bytes -> + ?close:(t -> unit) -> + consume:(t -> int -> unit) -> + fill:(t -> unit) -> + unit -> + t +(** [make ~fill ()] creates a byte stream. + @param fill is used to refill the buffer, and is called initially. + @param close optional closing. + @param init_size size of the buffer. +*) + +val with_file : ?buf_size:int -> string -> (t -> 'a) -> 'a +(** Open a file with given name, and obtain an input stream + on its content. When the function returns, the stream (and file) are closed. *) + +val read_line : ?buf:Tiny_httpd_buf.t -> t -> string +(** Read a line from the stream. + @param buf a buffer to (re)use. Its content will be cleared. *) + +val read_all : ?buf:Tiny_httpd_buf.t -> t -> string +(** Read the whole stream into a string. + @param buf a buffer to (re)use. Its content will be cleared. *) + +val limit_size_to : + close_rec:bool -> max_size:int -> too_big:(int -> unit) -> t -> t +(* New stream with maximum size [max_size]. + @param close_rec if true, closing this will also close the input stream + @param too_big called with read size if the max size is reached *) + +val read_chunked : ?buf:Tiny_httpd_buf.t -> fail:(string -> exn) -> t -> t +(** Convert a stream into a stream of byte chunks using + the chunked encoding. The size of chunks is not specified. + @param buf buffer used for intermediate storage. + @param fail used to build an exception if reading fails. +*) + +val read_exactly : + close_rec:bool -> size:int -> too_short:(int -> unit) -> t -> t +(** [read_exactly ~size bs] returns a new stream that reads exactly + [size] bytes from [bs], and then closes. + @param close_rec if true, closing the resulting stream also closes + [bs] + @param too_short is called if [bs] closes with still [n] bytes remaining +*) + +val output_chunked : ?buf:Tiny_httpd_buf.t -> out_channel -> t -> unit +(** Write the stream into the channel, using the chunked encoding. + @param buf optional buffer for chunking (since 0.14) *) + +val output_chunked' : + ?buf:Tiny_httpd_buf.t -> Tiny_httpd_io.Output.t -> t -> unit +(** Write the stream into the channel, using the chunked encoding. + @since 0.14 *) diff --git a/src/core/util.ml b/src/core/util.ml new file mode 100644 index 00000000..73617702 --- /dev/null +++ b/src/core/util.ml @@ -0,0 +1,121 @@ +let percent_encode ?(skip = fun _ -> false) s = + let buf = Buffer.create (String.length s) in + String.iter + (function + | c when skip c -> Buffer.add_char buf c + | ( ' ' | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '(' | ')' | '*' | '+' + | ',' | '/' | ':' | ';' | '=' | '?' | '@' | '[' | ']' | '~' ) as c -> + Printf.bprintf buf "%%%X" (Char.code c) + | c when Char.code c > 127 -> Printf.bprintf buf "%%%X" (Char.code c) + | c -> Buffer.add_char buf c) + s; + Buffer.contents buf + +let int_of_hex_nibble = function + | '0' .. '9' as c -> Char.code c - Char.code '0' + | 'a' .. 'f' as c -> 10 + Char.code c - Char.code 'a' + | 'A' .. 'F' as c -> 10 + Char.code c - Char.code 'A' + | _ -> invalid_arg "string: invalid hex" + +let percent_decode (s : string) : _ option = + let buf = Buffer.create (String.length s) in + let i = ref 0 in + try + while !i < String.length s do + match String.get s !i with + | '%' -> + if !i + 2 < String.length s then ( + (match + (int_of_hex_nibble (String.get s (!i + 1)) lsl 4) + + int_of_hex_nibble (String.get s (!i + 2)) + with + | n -> Buffer.add_char buf (Char.chr n) + | exception _ -> raise Exit); + i := !i + 3 + ) else + raise Exit (* truncated *) + | '+' -> + Buffer.add_char buf ' '; + incr i (* for query strings *) + | c -> + Buffer.add_char buf c; + incr i + done; + Some (Buffer.contents buf) + with Exit -> None + +exception Invalid_query + +let find_q_index_ s = String.index s '?' + +let get_non_query_path s = + match find_q_index_ s with + | i -> String.sub s 0 i + | exception Not_found -> s + +let get_query s : string = + match find_q_index_ s with + | i -> String.sub s (i + 1) (String.length s - i - 1) + | exception Not_found -> "" + +let split_query s = get_non_query_path s, get_query s + +let split_on_slash s : _ list = + let l = ref [] in + let i = ref 0 in + let n = String.length s in + while !i < n do + match String.index_from s !i '/' with + | exception Not_found -> + if !i < n then (* last component *) l := String.sub s !i (n - !i) :: !l; + i := n (* done *) + | j -> + if j > !i then l := String.sub s !i (j - !i) :: !l; + i := j + 1 + done; + List.rev !l + +let parse_query s : (_ list, string) result = + let pairs = ref [] in + let is_sep_ = function + | '&' | ';' -> true + | _ -> false + in + let i = ref 0 in + let j = ref 0 in + try + let percent_decode s = + match percent_decode s with + | Some x -> x + | None -> raise Invalid_query + in + let parse_pair () = + let eq = String.index_from s !i '=' in + let k = percent_decode @@ String.sub s !i (eq - !i) in + let v = percent_decode @@ String.sub s (eq + 1) (!j - eq - 1) in + pairs := (k, v) :: !pairs + in + while !i < String.length s do + while !j < String.length s && not (is_sep_ (String.get s !j)) do + incr j + done; + if !j < String.length s then ( + assert (is_sep_ (String.get s !j)); + parse_pair (); + i := !j + 1; + j := !i + ) else ( + parse_pair (); + i := String.length s (* done *) + ) + done; + Ok !pairs + with + | Invalid_argument _ | Not_found | Failure _ -> + Error (Printf.sprintf "error in parse_query for %S: i=%d,j=%d" s !i !j) + | Invalid_query -> Error ("invalid query string: " ^ s) + +let show_sockaddr = function + | Unix.ADDR_UNIX f -> f + | Unix.ADDR_INET (inet, port) -> + Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet) port diff --git a/src/core/util.mli b/src/core/util.mli new file mode 100644 index 00000000..ac996855 --- /dev/null +++ b/src/core/util.mli @@ -0,0 +1,40 @@ +(** {1 Some utils for writing web servers} + + @since 0.2 +*) + +val percent_encode : ?skip:(char -> bool) -> string -> string +(** Encode the string into a valid path following + https://tools.ietf.org/html/rfc3986#section-2.1 + @param skip if provided, allows to preserve some characters, e.g. '/' in a path. +*) + +val percent_decode : string -> string option +(** Inverse operation of {!percent_encode}. + Can fail since some strings are not valid percent encodings. *) + +val split_query : string -> string * string +(** Split a path between the path and the query + @since 0.5 *) + +val split_on_slash : string -> string list +(** Split a string on ['/'], remove the trailing ['/'] if any. + @since 0.6 *) + +val get_non_query_path : string -> string +(** get the part of the path that is not the query parameters. + @since 0.5 *) + +val get_query : string -> string +(** Obtain the query part of a path. + @since 0.4 *) + +val parse_query : string -> ((string * string) list, string) result +(** Parse a query as a list of ['&'] or [';'] separated [key=value] pairs. + The order might not be preserved. + @since 0.3 +*) + +val show_sockaddr : Unix.sockaddr -> string +(** Simple printer for socket addresses. + @since NEXT_RELEASE *) From 8e2cf23e2768c1f1d112f2c204dac82eb9cc4297 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 26 Feb 2024 13:42:18 -0500 Subject: [PATCH 02/20] add html sub-library --- src/html/Tiny_httpd_html.ml | 65 +++++ src/html/dune | 15 ++ src/html/gen/dune | 2 + src/html/gen/gentags.ml | 517 ++++++++++++++++++++++++++++++++++++ 4 files changed, 599 insertions(+) create mode 100644 src/html/Tiny_httpd_html.ml create mode 100644 src/html/dune create mode 100644 src/html/gen/dune create mode 100644 src/html/gen/gentags.ml diff --git a/src/html/Tiny_httpd_html.ml b/src/html/Tiny_httpd_html.ml new file mode 100644 index 00000000..0ae659d7 --- /dev/null +++ b/src/html/Tiny_httpd_html.ml @@ -0,0 +1,65 @@ +(** HTML combinators. + + This module provides combinators to produce html. It doesn't enforce + the well-formedness of the html, unlike Tyxml, but it's simple and should + be reasonably efficient. + @since 0.12 +*) + +module IO = Tiny_httpd_io + +include Html_ +(** @inline *) + +(** Write an HTML element to this output. + @param top if true, add DOCTYPE at the beginning. The top element should then + be a "html" tag. + @since 0.14 + *) +let to_output ?(top = false) (self : elt) (out : IO.Output.t) : unit = + let out = Out.create_of_out out in + if top then Out.add_string out "\n"; + self out; + Out.add_format_nl out; + Out.flush out + +(** Convert a HTML element to a string. + @param top if true, add DOCTYPE at the beginning. The top element should then + be a "html" tag. *) +let to_string ?top (self : elt) : string = + let buf = Buffer.create 64 in + let out = IO.Output.of_buffer buf in + to_output ?top self out; + Buffer.contents buf + +(** Convert a list of HTML elements to a string. + This is designed for fragments of HTML that are to be injected inside + a bigger context, as it's invalid to have multiple elements at the toplevel + of a HTML document. *) +let to_string_l (l : elt list) = + let buf = Buffer.create 64 in + let out = Out.create_of_buffer buf in + List.iter + (fun f -> + f out; + Out.add_format_nl out) + l; + Buffer.contents buf + +let to_string_top = to_string ~top:true + +(** Write a toplevel element to an output channel. + @since 0.14 *) +let to_out_channel_top = to_output ~top:true + +(** Produce a streaming writer from this HTML element. + @param top if true, add a DOCTYPE. See {!to_out_channel}. + @since 0.14 *) +let to_writer ?top (self : elt) : IO.Writer.t = + let write oc = to_output ?top self oc in + IO.Writer.make ~write () + +(** Convert a HTML element to a stream. This might just convert + it to a string first, do not assume it to be more efficient. *) +let to_stream (self : elt) : Tiny_httpd_stream.t = + Tiny_httpd_stream.of_string @@ to_string self diff --git a/src/html/dune b/src/html/dune new file mode 100644 index 00000000..c4648a3b --- /dev/null +++ b/src/html/dune @@ -0,0 +1,15 @@ + + +(library + (name tiny_httpd_html) + (public_name tiny_httpd.html) + (libraries seq tiny_httpd.html)) + +(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/html/gen/gentags.ml b/src/html/gen/gentags.ml new file mode 100644 index 00000000..c23bcfbc --- /dev/null +++ b/src/html/gen/gentags.ml @@ -0,0 +1,517 @@ +(* adapted from https://github.com/sindresorhus/html-tags (MIT licensed) *) + +let pf = Printf.printf +let spf = Printf.sprintf + +let void = + [ + "area"; + "base"; + "br"; + "col"; + "embed"; + "hr"; + "img"; + "input"; + "link"; + "menuitem"; + "meta"; + "param"; + "source"; + "track"; + "wbr"; + ] + +let normal = + [ + "a"; + "abbr"; + "address"; + "area"; + "article"; + "aside"; + "audio"; + "b"; + "base"; + "bdi"; + "bdo"; + "blockquote"; + "body"; + "br"; + "button"; + "canvas"; + "caption"; + "cite"; + "code"; + "col"; + "colgroup"; + "data"; + "datalist"; + "dd"; + "del"; + "details"; + "dfn"; + "dialog"; + "div"; + "dl"; + "dt"; + "em"; + "embed"; + "fieldset"; + "figcaption"; + "figure"; + "footer"; + "form"; + "h1"; + "h2"; + "h3"; + "h4"; + "h5"; + "h6"; + "head"; + "header"; + "hgroup"; + "hr"; + "html"; + "i"; + "iframe"; + "img"; + "input"; + "ins"; + "kbd"; + "label"; + "legend"; + "li"; + "link"; + "main"; + "map"; + "mark"; + "math"; + "menu"; + "menuitem"; + "meta"; + "meter"; + "nav"; + "noscript"; + "object"; + "ol"; + "optgroup"; + "option"; + "output"; + "p"; + "param"; + "picture"; + "pre"; + "progress"; + "q"; + "rb"; + "rp"; + "rt"; + "rtc"; + "ruby"; + "s"; + "samp"; + "script"; + "section"; + "select"; + "slot"; + "small"; + "source"; + "span"; + "strong"; + "style"; + "sub"; + "summary"; + "sup"; + "svg"; + "table"; + "tbody"; + "td"; + "template"; + "textarea"; + "tfoot"; + "th"; + "thead"; + "time"; + "title"; + "tr"; + "track"; + "u"; + "ul"; + "var"; + "video"; + "wbr"; + ] + |> List.filter (fun s -> not (List.mem s void)) + +(* obtained via: + {[ + l = Array(...document.querySelectorAll('div tbody td code a')).map( + x => x.firstChild.textContent); + JSON.stringify(l) + ]} + on https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes +*) +let attrs = + [ + "accept"; + "accept-charset"; + "accesskey"; + "action"; + "align"; + "allow"; + "alt"; + "async"; + "autocapitalize"; + "autocomplete"; + "autofocus"; + "autoplay"; + "buffered"; + "capture"; + "challenge"; + "charset"; + "checked"; + "cite"; + "class"; + "code"; + "codebase"; + "cols"; + "colspan"; + "content"; + "contenteditable"; + "contextmenu"; + "controls"; + "coords"; + "crossorigin"; + "csp"; + "data"; + "data-*"; + "datetime"; + "decoding"; + "default"; + "defer"; + "dir"; + "dirname"; + "disabled"; + "download"; + "draggable"; + "enctype"; + "enterkeyhint"; + "for"; + "form"; + "formaction"; + "formenctype"; + "formmethod"; + "formnovalidate"; + "formtarget"; + "headers"; + "hidden"; + "high"; + "href"; + "hreflang"; + "http-equiv"; + "icon"; + "id"; + "importance"; + "integrity"; + "ismap"; + "itemprop"; + "keytype"; + "kind"; + "label"; + "lang"; + "language"; + "list"; + "loop"; + "low"; + "manifest"; + "max"; + "maxlength"; + "minlength"; + "media"; + "method"; + "min"; + "multiple"; + "muted"; + "name"; + "novalidate"; + "open"; + "optimum"; + "pattern"; + "ping"; + "placeholder"; + "poster"; + "preload"; + "radiogroup"; + "readonly"; + "referrerpolicy"; + "rel"; + "required"; + "reversed"; + "rows"; + "rowspan"; + "sandbox"; + "scope"; + "scoped"; + "selected"; + "shape"; + "size"; + "sizes"; + "slot"; + "span"; + "spellcheck"; + "src"; + "srcdoc"; + "srclang"; + "srcset"; + "start"; + "step"; + "style"; + "summary"; + "tabindex"; + "target"; + "title"; + "translate"; + "Text"; + "type"; + "usemap"; + "value"; + "width"; + "wrap"; + ] + +let prelude = + {| +(** Output for HTML combinators. + + This output type is used to produce a string reasonably efficiently from + a tree of combinators. + + {b NOTE}: this is experimental and an unstable API. + + @since 0.12 + @open *) +module Out : sig + type t + val create_of_buffer : Buffer.t -> t + val create_of_out: Tiny_httpd_io.Output.t -> t + val flush : t -> unit + val add_char : t -> char -> unit + val add_string : t -> string -> unit + val add_format_nl : t -> unit + val with_no_format_nl : t -> (unit -> 'a) -> 'a +end = struct + module IO = Tiny_httpd_io + type t = { + out: IO.Output.t; + mutable fmt_nl: bool; (* if true, we print [\n] around tags to format the html *) + } + let create_of_out out = {out; fmt_nl=true} + let create_of_buffer buf : t = create_of_out (IO.Output.of_buffer buf) + let[@inline] flush self : unit = IO.Output.flush self.out + let[@inline] add_char self c = IO.Output.output_char self.out c + let[@inline] add_string self s = IO.Output.output_string self.out s + let[@inline] add_format_nl self = if self.fmt_nl then add_char self '\n' + let with_no_format_nl self f = + if self.fmt_nl then ( + self.fmt_nl <- false; + try let x=f() in self.fmt_nl <- true; x with e -> self.fmt_nl <- true; raise e + ) else f() +end + +type attribute = string * string +(** An attribute, i.e. a key/value pair *) + +type elt = Out.t -> unit +(** A html element. It is represented by its output function, so we + can directly print it. *) + +type void = ?if_:bool -> attribute list -> elt +(** Element without children. *) + +type nary = ?if_:bool -> attribute list -> elt list -> elt +(** Element with children, represented as a list. + @param if_ if false, do not print anything (default true) *) + +(** A chunk of sub-elements, possibly empty. + @inline *) +type sub_elt = [ `E of elt | `L of elt list | `S of elt Seq.t | `Nil] + +type nary' = ?if_:bool -> attribute list -> sub_elt list -> elt +(** Element with children, represented as a list of {!sub_elt} to be flattened + @param if_ if false, do not print anything (default true) *) + +(**/**) +module Helpers_ = struct + +(** Escape string so it can be safely embedded in HTML text. *) +let _str_escape (out:Out.t) (s:string) : unit = + String.iter (function + | '<' -> Out.add_string out "<" + | '>' -> Out.add_string out ">" + | '&' -> Out.add_string out "&" + | '"' -> Out.add_string out """ + | '\'' -> Out.add_string out "'" + | c -> Out.add_char out c) + s + +(** Print the value part of an attribute *) +let _attr_escape (out:Out.t) (s:string) = + Out.add_char out '"'; + _str_escape out s; + Out.add_char out '"' + +(** Output a list of attributes. *) +let _write_attrs (out:Out.t) (l:attribute list) : unit = + List.iter + (fun (k,v) -> + Out.add_char out ' '; + Out.add_string out k; + Out.add_char out '='; + _attr_escape out v) + l + +(** Write sub-elements of a {!nary'} element, returns [true] iff + at least one sub-element was written. *) +let _write_subs (out:Out.t) (l:sub_elt list) : bool = + let has_sub = ref false in + let prepend_white () = has_sub := true; Out.add_format_nl out; in + let emit1 = function + | `E x -> prepend_white(); x out + | `L l -> List.iter (fun e -> prepend_white(); e out) l + | `S l -> Seq.iter (fun e -> prepend_white(); e out) l + | `Nil -> () + in + List.iter emit1 l; + !has_sub + +(** Write a tag, with its attributes. + @param void if true, end with "/>", otherwise end with ">" *) +let _write_tag_attrs ~void (out:Out.t) (tag:string) (attrs:attribute list) : unit = + Out.add_string out "<"; + Out.add_string out tag; + _write_attrs out attrs; + if void then Out.add_string out "/>" else Out.add_string out ">" + +end +open Helpers_ +(**/**) + +(** Sub-element with a single element inside. *) +let[@inline] sub_e (elt:elt) : sub_elt = `E elt + +(** Sub-element with a list of items inside. *) +let[@inline] sub_l (l:elt list) : sub_elt = `L l + +(** Sub-element with a sequence ({!Seq.t}) of items inside. *) +let[@inline] sub_seq (l:elt Seq.t) : sub_elt = `S l + +(** Helper to build a {!Seq.t} from an array. *) +let seq_of_array (a:_ array) : _ Seq.t = + let rec loop i () = + if i=Array.length a then Seq.Nil + else Seq.Cons (a.(i), loop (i+1)) + in loop 0 + +(** Sub-element with nothing inside. Useful in conditionals, when one + decides not to emit a sub-element at all. *) +let sub_empty : sub_elt = `Nil + +(** Emit a string value, which will be escaped. *) +let txt (txt:string) : elt = fun out -> _str_escape out txt + +(** Formatted version of {!txt} *) +let txtf fmt = Format.kasprintf (fun s -> fun out -> _str_escape out s) fmt + +(** Emit raw HTML. Caution, this can lead to injection vulnerabilities, + never use with text that comes from untrusted users. *) +let raw_html (s:string) : elt = fun out -> Out.add_string out s +|} + +let oname = function + | "object" -> "object_" + | "class" -> "class_" + | "method" -> "method_" + | "data-*" -> "data_star" + | "for" -> "for_" + | "open" -> "open_" + | "Text" -> "text" + | "type" -> "type_" + | name -> + String.map + (function + | '-' -> '_' + | c -> c) + name + +let emit_void name = + let oname = oname name in + pf + "(** tag %S, see \ + {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n" + name name; + pf "let %s : void = fun ?(if_=true) attrs out ->\n" oname; + pf " if if_ then (\n"; + pf " _write_tag_attrs ~void:true out %S attrs;\n" name; + pf " )"; + pf "\n\n"; + () + +let emit_normal name = + let oname = oname name in + + pf + "(** tag %S, see \ + {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n" + name name; + pf "let %s : nary = fun ?(if_=true) attrs sub out ->\n" oname; + pf " if if_ then (\n"; + (* for 
, newlines actually matter *)
+  if name = "pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
+  pf "    _write_tag_attrs ~void:false out %S attrs;\n" name;
+  pf "    List.iter (fun sub -> Out.add_format_nl out; sub out) sub;\n";
+  pf "    if sub <> [] then Out.add_format_nl out;\n";
+  pf "    Out.add_string out \"\")" name;
+  pf "\n\n";
+
+  (* block version *)
+  let oname = oname ^ "'" in
+  pf
+    "(** tag %S, see \
+     {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
+    name name;
+  pf "let %s : nary' = fun ?(if_=true) attrs l out ->\n" oname;
+  pf "  if if_ then (\n";
+  if name = "pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
+  pf "    _write_tag_attrs ~void:false out %S attrs;\n" name;
+  pf "    let has_sub = _write_subs out l in\n";
+  pf "    if has_sub then Out.add_format_nl out;\n";
+  pf "    Out.add_string out \"\")" name;
+  pf "\n\n";
+
+  ()
+
+let doc_attrs =
+  {|Attributes.
+
+This module contains combinator for the standard attributes.
+One can also just use a pair of strings. |}
+
+let emit_attr name =
+  let oname = oname name in
+  pf "  (** Attribute %S. *)\n" name;
+  pf "  let %s : t = fun v -> %S, v\n" oname name;
+  pf "\n"
+
+let () =
+  pf "%s\n" prelude;
+  List.iter emit_void void;
+  List.iter emit_normal normal;
+  pf "(** %s *)\n" doc_attrs;
+  pf "module A = struct\n";
+  pf "  type t = string -> attribute\n";
+  pf "  (** Attribute builder *)\n";
+  pf "\n";
+  List.iter emit_attr attrs;
+  pf "end\n";
+  ()

From 04be73ee00ecf7b7500fcf24252b29d4b9c08a54 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Mon, 26 Feb 2024 13:55:20 -0500
Subject: [PATCH 03/20] refactor the rest

---
 .gitmodules                              |    3 +
 dune-project                             |    2 +
 src/Tiny_httpd.ml                        |   66 +-
 src/Tiny_httpd.mli                       |   18 +-
 src/Tiny_httpd_buf.ml                    |   55 -
 src/Tiny_httpd_buf.mli                   |   42 -
 src/Tiny_httpd_html.ml                   |   65 --
 src/Tiny_httpd_io.ml                     |  370 ------
 src/Tiny_httpd_log.default.ml            |    7 -
 src/Tiny_httpd_log.logs.ml               |   22 -
 src/Tiny_httpd_log.mli                   |   12 -
 src/Tiny_httpd_mime_.dummy.ml            |    1 -
 src/Tiny_httpd_mime_.magic.ml            |    1 -
 src/Tiny_httpd_mime_.mli                 |    2 -
 src/Tiny_httpd_parse_.ml                 |   77 --
 src/Tiny_httpd_pool.ml                   |   51 -
 src/Tiny_httpd_pool.mli                  |   25 -
 src/Tiny_httpd_server.ml                 | 1338 ----------------------
 src/Tiny_httpd_server.mli                |  719 ------------
 src/Tiny_httpd_stream.ml                 |  322 ------
 src/Tiny_httpd_stream.mli                |  159 ---
 src/Tiny_httpd_util.ml                   |  121 --
 src/Tiny_httpd_util.mli                  |   40 -
 src/core/IO.ml                           |   11 +-
 src/core/dune                            |    5 +-
 src/core/server.ml                       |    9 +-
 src/core/util.ml                         |    2 +
 src/core/util.mli                        |    4 +
 src/dune                                 |   30 +-
 src/gen/dune                             |    2 -
 src/gen/gentags.ml                       |  517 ---------
 src/gen/mkshims.ml                       |   41 -
 src/html/Tiny_httpd_html.ml              |    6 +-
 src/html/dune                            |    3 +-
 src/html/gen/gentags.ml                  |    3 +-
 src/{Tiny_httpd_dir.ml => unix/dir.ml}   |   64 +-
 src/{Tiny_httpd_dir.mli => unix/dir.mli} |   10 +-
 src/unix/dune                            |   12 +
 src/{core => unix}/mime_.dummy.ml        |    0
 src/{core => unix}/mime_.magic.ml        |    0
 src/{core => unix}/mime_.mli             |    0
 src/unix/sem.ml                          |   25 +
 src/unix/tiny_httpd_unix.ml              |  155 +++
 tiny_httpd.opam                          |    1 +
 vendor/iostream                          |    1 +
 45 files changed, 322 insertions(+), 4097 deletions(-)
 create mode 100644 .gitmodules
 delete mode 100644 src/Tiny_httpd_buf.ml
 delete mode 100644 src/Tiny_httpd_buf.mli
 delete mode 100644 src/Tiny_httpd_html.ml
 delete mode 100644 src/Tiny_httpd_io.ml
 delete mode 100644 src/Tiny_httpd_log.default.ml
 delete mode 100644 src/Tiny_httpd_log.logs.ml
 delete mode 100644 src/Tiny_httpd_log.mli
 delete mode 100644 src/Tiny_httpd_mime_.dummy.ml
 delete mode 100644 src/Tiny_httpd_mime_.magic.ml
 delete mode 100644 src/Tiny_httpd_mime_.mli
 delete mode 100644 src/Tiny_httpd_parse_.ml
 delete mode 100644 src/Tiny_httpd_pool.ml
 delete mode 100644 src/Tiny_httpd_pool.mli
 delete mode 100644 src/Tiny_httpd_server.ml
 delete mode 100644 src/Tiny_httpd_server.mli
 delete mode 100644 src/Tiny_httpd_stream.ml
 delete mode 100644 src/Tiny_httpd_stream.mli
 delete mode 100644 src/Tiny_httpd_util.ml
 delete mode 100644 src/Tiny_httpd_util.mli
 delete mode 100644 src/gen/dune
 delete mode 100644 src/gen/gentags.ml
 delete mode 100644 src/gen/mkshims.ml
 rename src/{Tiny_httpd_dir.ml => unix/dir.ml} (87%)
 rename src/{Tiny_httpd_dir.mli => unix/dir.mli} (94%)
 create mode 100644 src/unix/dune
 rename src/{core => unix}/mime_.dummy.ml (100%)
 rename src/{core => unix}/mime_.magic.ml (100%)
 rename src/{core => unix}/mime_.mli (100%)
 create mode 100644 src/unix/sem.ml
 create mode 100644 src/unix/tiny_httpd_unix.ml
 create mode 160000 vendor/iostream

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..468a58dd 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)
diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml
index dfdd3b46..422a7cdb 100644
--- a/src/Tiny_httpd.ml
+++ b/src/Tiny_httpd.ml
@@ -1,9 +1,59 @@
-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
+include Server
+module Util = Util
+module Dir = Tiny_httpd_unix.Dir
 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 Pool = Tiny_httpd_core.Pool
+module Log = Tiny_httpd_core.Log
+
+open struct
+  let get_max_connection_ ?(max_connections = 64) () : int =
+    let max_connections = max 4 max_connections in
+    max_connections
+
+  let clear_slice (slice : IO.Slice.t) =
+    Bytes.fill slice.bytes 0 (Bytes.length slice.bytes) '\x00';
+    slice.off <- 0;
+    slice.len <- 0
+end
+
+let create ?(masksigpipe = true) ?max_connections ?(timeout = 0.0) ?buf_size
+    ?(get_time_s = Unix.gettimeofday)
+    ?(new_thread = fun f -> ignore (Thread.create f () : Thread.t))
+    ?(addr = "127.0.0.1") ?(port = 8080) ?sock ?middlewares () : t =
+  let max_connections = get_max_connection_ ?max_connections () in
+  let server =
+    {
+      Tiny_httpd_unix.Unix_tcp_server_.addr;
+      new_thread;
+      buf_pool =
+        Pool.create ~clear:Buf.clear_and_zero
+          ~mk_item:(fun () -> Buf.create ?size:buf_size ())
+          ();
+      slice_pool =
+        Pool.create ~clear:clear_slice
+          ~mk_item:
+            (let buf_size = Option.value buf_size ~default:4096 in
+             fun () -> IO.Slice.create buf_size)
+          ();
+      running = true;
+      port;
+      sock;
+      max_connections;
+      sem_max_connections = Tiny_httpd_unix.Sem.create max_connections;
+      masksigpipe;
+      timeout;
+    }
+  in
+  let tcp_server_builder =
+    Tiny_httpd_unix.Unix_tcp_server_.to_tcp_server server
+  in
+  let module B = struct
+    let init_addr () = addr
+    let init_port () = port
+    let get_time_s = get_time_s
+    let tcp_server () = tcp_server_builder
+  end in
+  let backend = (module B : IO_BACKEND) in
+  Server.create_from ?buf_size ?middlewares ~backend ()
diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli
index b4cc6e89..167b5873 100644
--- a/src/Tiny_httpd.mli
+++ b/src/Tiny_httpd.mli
@@ -79,38 +79,34 @@ 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
+module Log = Tiny_httpd_core.Log
 
 (** {2 Main Server Type} *)
 
 (** @inline *)
 include module type of struct
-  include Tiny_httpd_server
+  include Tiny_httpd_core.Server
 end
 
 (** {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 Html = Tiny_httpd_html
 (** Alias to {!Tiny_httpd_html}
diff --git a/src/Tiny_httpd_buf.ml b/src/Tiny_httpd_buf.ml
deleted file mode 100644
index fcc89933..00000000
--- a/src/Tiny_httpd_buf.ml
+++ /dev/null
@@ -1,55 +0,0 @@
-type t = { mutable bytes: bytes; mutable i: int; original: bytes }
-
-let create ?(size = 4_096) () : t =
-  let bytes = Bytes.make size ' ' in
-  { bytes; i = 0; original = bytes }
-
-let[@inline] size self = self.i
-let[@inline] bytes_slice self = self.bytes
-
-let clear self : unit =
-  if
-    Bytes.length self.bytes > 500 * 1_024
-    && Bytes.length self.bytes > Bytes.length self.original
-  then
-    (* free big buffer *)
-    self.bytes <- self.original;
-  self.i <- 0
-
-let clear_and_zero self =
-  clear self;
-  Bytes.fill self.bytes 0 (Bytes.length self.bytes) '\x00'
-
-let resize self new_size : unit =
-  let new_buf = Bytes.make new_size ' ' in
-  Bytes.blit self.bytes 0 new_buf 0 self.i;
-  self.bytes <- new_buf
-
-let add_char self c : unit =
-  if self.i + 1 >= Bytes.length self.bytes then
-    resize self (self.i + (self.i / 2) + 10);
-  Bytes.set self.bytes self.i c;
-  self.i <- 1 + self.i
-
-let add_bytes (self : t) s i len : unit =
-  if self.i + len >= Bytes.length self.bytes then
-    resize self (self.i + (self.i / 2) + len + 10);
-  Bytes.blit s i self.bytes self.i len;
-  self.i <- self.i + len
-
-let[@inline] add_string self str : unit =
-  add_bytes self (Bytes.unsafe_of_string str) 0 (String.length str)
-
-let add_buffer (self : t) (buf : Buffer.t) : unit =
-  let len = Buffer.length buf in
-  if self.i + len >= Bytes.length self.bytes then
-    resize self (self.i + (self.i / 2) + len + 10);
-  Buffer.blit buf 0 self.bytes self.i len;
-  self.i <- self.i + len
-
-let contents (self : t) : string = Bytes.sub_string self.bytes 0 self.i
-
-let contents_and_clear (self : t) : string =
-  let x = contents self in
-  clear self;
-  x
diff --git a/src/Tiny_httpd_buf.mli b/src/Tiny_httpd_buf.mli
deleted file mode 100644
index e5ca90c1..00000000
--- a/src/Tiny_httpd_buf.mli
+++ /dev/null
@@ -1,42 +0,0 @@
-(** Simple buffer.
-
-    These buffers are used to avoid allocating too many byte arrays when
-    processing streams and parsing requests.
-
-    @since 0.12
-*)
-
-type t
-
-val size : t -> int
-val clear : t -> unit
-val create : ?size:int -> unit -> t
-val contents : t -> string
-
-val clear_and_zero : t -> unit
-(** Clear the buffer and zero out its storage.
-    @since 0.15 *)
-
-val bytes_slice : t -> bytes
-(** Access underlying slice of bytes.
-    @since 0.5 *)
-
-val contents_and_clear : t -> string
-(** Get contents of the buffer and clear it.
-    @since 0.5 *)
-
-val add_char : t -> char -> unit
-(** Add a single char.
-    @since 0.14 *)
-
-val add_bytes : t -> bytes -> int -> int -> unit
-(** Append given bytes slice to the buffer.
-    @since 0.5 *)
-
-val add_string : t -> string -> unit
-(** Add string.
-    @since 0.14 *)
-
-val add_buffer : t -> Buffer.t -> unit
-(** Append bytes from buffer.
-    @since 0.14 *)
diff --git a/src/Tiny_httpd_html.ml b/src/Tiny_httpd_html.ml
deleted file mode 100644
index 61f0416b..00000000
--- a/src/Tiny_httpd_html.ml
+++ /dev/null
@@ -1,65 +0,0 @@
-(** HTML combinators.
-
-    This module provides combinators to produce html. It doesn't enforce
-    the well-formedness of the html, unlike Tyxml, but it's simple and should
-    be reasonably efficient.
-    @since 0.12
-*)
-
-module IO = Tiny_httpd_io
-
-include Tiny_httpd_html_
-(** @inline *)
-
-(** Write an HTML element to this output.
-    @param top if true, add DOCTYPE at the beginning. The top element should then
-    be a "html" tag.
-    @since 0.14
-    *)
-let to_output ?(top = false) (self : elt) (out : IO.Output.t) : unit =
-  let out = Out.create_of_out out in
-  if top then Out.add_string out "\n";
-  self out;
-  Out.add_format_nl out;
-  Out.flush out
-
-(** Convert a HTML element to a string.
-    @param top if true, add DOCTYPE at the beginning. The top element should then
-    be a "html" tag. *)
-let to_string ?top (self : elt) : string =
-  let buf = Buffer.create 64 in
-  let out = IO.Output.of_buffer buf in
-  to_output ?top self out;
-  Buffer.contents buf
-
-(** Convert a list of HTML elements to a string.
-    This is designed for fragments of HTML that are to be injected inside
-    a bigger context, as it's invalid to have multiple elements at the toplevel
-    of a HTML document. *)
-let to_string_l (l : elt list) =
-  let buf = Buffer.create 64 in
-  let out = Out.create_of_buffer buf in
-  List.iter
-    (fun f ->
-      f out;
-      Out.add_format_nl out)
-    l;
-  Buffer.contents buf
-
-let to_string_top = to_string ~top:true
-
-(** Write a toplevel element to an output channel.
-    @since 0.14 *)
-let to_out_channel_top = to_output ~top:true
-
-(** Produce a streaming writer from this HTML element.
-    @param top if true, add a DOCTYPE. See {!to_out_channel}.
-    @since 0.14 *)
-let to_writer ?top (self : elt) : IO.Writer.t =
-  let write oc = to_output ?top self oc in
-  IO.Writer.make ~write ()
-
-(** Convert a HTML element to a stream. This might just convert
-    it to a string first, do not assume it to be more efficient. *)
-let to_stream (self : elt) : Tiny_httpd_stream.t =
-  Tiny_httpd_stream.of_string @@ to_string self
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_log.default.ml b/src/Tiny_httpd_log.default.ml
deleted file mode 100644
index 5340578b..00000000
--- a/src/Tiny_httpd_log.default.ml
+++ /dev/null
@@ -1,7 +0,0 @@
-(* default: no logging *)
-
-let info _ = ()
-let debug _ = ()
-let error _ = ()
-let setup ~debug:_ () = ()
-let dummy = true
diff --git a/src/Tiny_httpd_log.logs.ml b/src/Tiny_httpd_log.logs.ml
deleted file mode 100644
index f2cc8f56..00000000
--- a/src/Tiny_httpd_log.logs.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(* Use Logs *)
-
-module Log = (val Logs.(src_log @@ Src.create "tiny_httpd"))
-
-let info k = Log.info (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
-let debug k = Log.debug (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
-let error k = Log.err (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
-
-let setup ~debug () =
-  let mutex = Mutex.create () in
-  Logs.set_reporter_mutex
-    ~lock:(fun () -> Mutex.lock mutex)
-    ~unlock:(fun () -> Mutex.unlock mutex);
-  Logs.set_reporter @@ Logs.format_reporter ();
-  Logs.set_level ~all:true
-    (Some
-       (if debug then
-         Logs.Debug
-       else
-         Logs.Info))
-
-let dummy = false
diff --git a/src/Tiny_httpd_log.mli b/src/Tiny_httpd_log.mli
deleted file mode 100644
index 5944e125..00000000
--- a/src/Tiny_httpd_log.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-(** Logging for tiny_httpd *)
-
-val info : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
-val debug : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
-val error : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
-
-val setup : debug:bool -> unit -> unit
-(** Setup and enable logging. This should only ever be used in executables,
-    not libraries.
-    @param debug if true, set logging to debug (otherwise info) *)
-
-val dummy : bool
diff --git a/src/Tiny_httpd_mime_.dummy.ml b/src/Tiny_httpd_mime_.dummy.ml
deleted file mode 100644
index dc944b1c..00000000
--- a/src/Tiny_httpd_mime_.dummy.ml
+++ /dev/null
@@ -1 +0,0 @@
-let mime_of_path _ = "application/octet-stream"
diff --git a/src/Tiny_httpd_mime_.magic.ml b/src/Tiny_httpd_mime_.magic.ml
deleted file mode 100644
index 72fcd345..00000000
--- a/src/Tiny_httpd_mime_.magic.ml
+++ /dev/null
@@ -1 +0,0 @@
-let mime_of_path s = Magic_mime.lookup s
diff --git a/src/Tiny_httpd_mime_.mli b/src/Tiny_httpd_mime_.mli
deleted file mode 100644
index 1831c02d..00000000
--- a/src/Tiny_httpd_mime_.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-
-val mime_of_path :  string -> string
diff --git a/src/Tiny_httpd_parse_.ml b/src/Tiny_httpd_parse_.ml
deleted file mode 100644
index 39430889..00000000
--- a/src/Tiny_httpd_parse_.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(** Basic parser for lines *)
-
-type 'a t = string -> int ref -> 'a
-
-open struct
-  let spf = Printf.sprintf
-end
-
-let[@inline] eof s off = !off = String.length s
-
-let[@inline] skip_space : unit t =
- fun s off ->
-  while !off < String.length s && String.unsafe_get s !off = ' ' do
-    incr off
-  done
-
-let pos_int : int t =
- fun s off : int ->
-  skip_space s off;
-  let n = ref 0 in
-  let continue = ref true in
-  while !off < String.length s && !continue do
-    match String.unsafe_get s !off with
-    | '0' .. '9' as c -> n := (!n * 10) + Char.code c - Char.code '0'
-    | ' ' | '\t' | '\n' -> continue := false
-    | c -> failwith @@ spf "expected int, got %C" c
-  done;
-  !n
-
-let pos_hex : int t =
- fun s off : int ->
-  skip_space s off;
-  let n = ref 0 in
-  let continue = ref true in
-  while !off < String.length s && !continue do
-    match String.unsafe_get s !off with
-    | 'a' .. 'f' as c ->
-      incr off;
-      n := (!n * 16) + Char.code c - Char.code 'a' + 10
-    | 'A' .. 'F' as c ->
-      incr off;
-      n := (!n * 16) + Char.code c - Char.code 'A' + 10
-    | '0' .. '9' as c ->
-      incr off;
-      n := (!n * 16) + Char.code c - Char.code '0'
-    | ' ' | '\r' -> continue := false
-    | c -> failwith @@ spf "expected int, got %C" c
-  done;
-  !n
-
-(** Parse a word without spaces *)
-let word : string t =
- fun s off ->
-  skip_space s off;
-  let start = !off in
-  let continue = ref true in
-  while !off < String.length s && !continue do
-    match String.unsafe_get s !off with
-    | ' ' | '\r' -> continue := false
-    | _ -> incr off
-  done;
-  if !off = start then failwith "expected word";
-  String.sub s start (!off - start)
-
-let exact str : unit t =
- fun s off ->
-  skip_space s off;
-  let len = String.length str in
-  if !off + len > String.length s then
-    failwith @@ spf "unexpected EOF, expected %S" str;
-  for i = 0 to len - 1 do
-    let expected = String.unsafe_get str i in
-    let c = String.unsafe_get s (!off + i) in
-    if c <> expected then
-      failwith @@ spf "expected %S, got %C at position %d" str c i
-  done;
-  off := !off + len
diff --git a/src/Tiny_httpd_pool.ml b/src/Tiny_httpd_pool.ml
deleted file mode 100644
index 1a441944..00000000
--- a/src/Tiny_httpd_pool.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-module A = Tiny_httpd_atomic_
-
-type 'a list_ = Nil | Cons of int * 'a * 'a list_
-
-type 'a t = {
-  mk_item: unit -> 'a;
-  clear: 'a -> unit;
-  max_size: int;  (** Max number of items *)
-  items: 'a list_ A.t;
-}
-
-let create ?(clear = ignore) ~mk_item ?(max_size = 512) () : _ t =
-  { mk_item; clear; max_size; items = A.make Nil }
-
-let rec acquire_ self =
-  match A.get self.items with
-  | Nil -> self.mk_item ()
-  | Cons (_, x, tl) as l ->
-    if A.compare_and_set self.items l tl then
-      x
-    else
-      acquire_ self
-
-let[@inline] size_ = function
-  | Cons (sz, _, _) -> sz
-  | Nil -> 0
-
-let release_ self x : unit =
-  let rec loop () =
-    match A.get self.items with
-    | Cons (sz, _, _) when sz >= self.max_size ->
-      (* forget the item *)
-      ()
-    | l ->
-      if not (A.compare_and_set self.items l (Cons (size_ l + 1, x, l))) then
-        loop ()
-  in
-
-  self.clear x;
-  loop ()
-
-let with_resource (self : _ t) f =
-  let x = acquire_ self in
-  try
-    let res = f x in
-    release_ self x;
-    res
-  with e ->
-    let bt = Printexc.get_raw_backtrace () in
-    release_ self x;
-    Printexc.raise_with_backtrace e bt
diff --git a/src/Tiny_httpd_pool.mli b/src/Tiny_httpd_pool.mli
deleted file mode 100644
index a2418e11..00000000
--- a/src/Tiny_httpd_pool.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(** Resource pool.
-
-    This pool is used for buffers. It can be used for other resources
-    but do note that it assumes resources are still reasonably
-    cheap to produce and discard, and will never block waiting for
-    a resource — it's not a good pool for DB connections.
-
-    @since 0.14. *)
-
-type 'a t
-(** Pool of values of type ['a] *)
-
-val create :
-  ?clear:('a -> unit) -> mk_item:(unit -> 'a) -> ?max_size:int -> unit -> 'a t
-(** Create a new pool.
-    @param mk_item produce a new item in case the pool is empty
-    @param max_size maximum number of item in the pool before we start
-      dropping resources on the floor. This controls resource consumption.
-    @param clear a function called on items before recycling them.
- *)
-
-val with_resource : 'a t -> ('a -> 'b) -> 'b
-(** [with_resource pool f] runs [f x] with [x] a resource;
-    when [f] fails or returns, [x] is returned to the pool for
-    future reuse. *)
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/Tiny_httpd_stream.ml b/src/Tiny_httpd_stream.ml
deleted file mode 100644
index a845c8bf..00000000
--- a/src/Tiny_httpd_stream.ml
+++ /dev/null
@@ -1,322 +0,0 @@
-module Buf = Tiny_httpd_buf
-module IO = Tiny_httpd_io
-
-let spf = Printf.sprintf
-
-type hidden = unit
-
-type t = {
-  mutable bs: bytes;
-  mutable off: int;
-  mutable len: int;
-  fill_buf: unit -> unit;
-  consume: int -> unit;
-  close: unit -> unit;
-  _rest: hidden;
-}
-
-let[@inline] close self = self.close ()
-
-let empty =
-  {
-    bs = Bytes.empty;
-    off = 0;
-    len = 0;
-    fill_buf = ignore;
-    consume = ignore;
-    close = ignore;
-    _rest = ();
-  }
-
-let make ?(bs = Bytes.create @@ (16 * 1024)) ?(close = ignore) ~consume ~fill ()
-    : t =
-  let rec self =
-    {
-      bs;
-      off = 0;
-      len = 0;
-      close = (fun () -> close self);
-      fill_buf = (fun () -> if self.len = 0 then fill self);
-      consume =
-        (fun n ->
-          assert (n <= self.len);
-          consume self n);
-      _rest = ();
-    }
-  in
-  self
-
-let of_input ?(buf_size = 16 * 1024) (ic : IO.Input.t) : t =
-  make ~bs:(Bytes.create buf_size)
-    ~close:(fun _ -> IO.Input.close ic)
-    ~consume:(fun self n ->
-      assert (self.len >= n);
-      self.off <- self.off + n;
-      self.len <- self.len - n)
-    ~fill:(fun self ->
-      if self.len = 0 then (
-        self.off <- 0;
-        self.len <- IO.Input.input ic self.bs 0 (Bytes.length self.bs)
-      ))
-    ()
-
-let of_chan_ ?buf_size ic ~close_noerr : t =
-  let inc = IO.Input.of_in_channel ~close_noerr ic in
-  of_input ?buf_size inc
-
-let of_chan ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:false
-let of_chan_close_noerr ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:true
-
-let of_fd_ ?buf_size ~close_noerr ~closed ic : t =
-  let inc = IO.Input.of_unix_fd ~close_noerr ~closed ic in
-  of_input ?buf_size inc
-
-let of_fd ?buf_size ~closed fd : t =
-  of_fd_ ?buf_size ~closed ~close_noerr:false fd
-
-let of_fd_close_noerr ?buf_size ~closed fd : t =
-  of_fd_ ?buf_size ~closed ~close_noerr:true fd
-
-let iter f (self : t) : unit =
-  let continue = ref true in
-  while !continue do
-    self.fill_buf ();
-    if self.len = 0 then (
-      continue := false;
-      self.close ()
-    ) else (
-      f self.bs self.off self.len;
-      self.consume self.len
-    )
-  done
-
-let to_chan (oc : out_channel) (self : t) = iter (output oc) self
-let to_chan' (oc : IO.Output.t) (self : t) = iter (IO.Output.output oc) self
-
-let to_writer (self : t) : Tiny_httpd_io.Writer.t =
-  { write = (fun oc -> to_chan' oc self) }
-
-let of_bytes ?(i = 0) ?len (bs : bytes) : t =
-  (* invariant: !i+!len is constant *)
-  let len =
-    match len with
-    | Some n ->
-      if n > Bytes.length bs - i then invalid_arg "Byte_stream.of_bytes";
-      n
-    | None -> Bytes.length bs - i
-  in
-  let self =
-    make ~bs ~fill:ignore
-      ~close:(fun self -> self.len <- 0)
-      ~consume:(fun self n ->
-        assert (n >= 0 && n <= self.len);
-        self.off <- n + self.off;
-        self.len <- self.len - n)
-      ()
-  in
-  self.off <- i;
-  self.len <- len;
-  self
-
-let of_string s : t = of_bytes (Bytes.unsafe_of_string s)
-
-let with_file ?buf_size file f =
-  let ic = Unix.(openfile file [ O_RDONLY ] 0) in
-  try
-    let x = f (of_fd ?buf_size ~closed:(ref false) ic) in
-    Unix.close ic;
-    x
-  with e ->
-    Unix.close ic;
-    raise e
-
-let read_all ?(buf = Buf.create ()) (self : t) : string =
-  let continue = ref true in
-  while !continue do
-    self.fill_buf ();
-    if self.len = 0 then
-      continue := false
-    else (
-      assert (self.len > 0);
-      Buf.add_bytes buf self.bs self.off self.len;
-      self.consume self.len
-    )
-  done;
-  Buf.contents_and_clear buf
-
-(* put [n] bytes from the input into bytes *)
-let read_exactly_ ~too_short (self : t) (bytes : bytes) (n : int) : unit =
-  assert (Bytes.length bytes >= n);
-  let offset = ref 0 in
-  while !offset < n do
-    self.fill_buf ();
-    let n_read = min self.len (n - !offset) in
-    Bytes.blit self.bs self.off bytes !offset n_read;
-    offset := !offset + n_read;
-    self.consume n_read;
-    if n_read = 0 then too_short ()
-  done
-
-(* read a line into the buffer, after clearing it. *)
-let read_line_into (self : t) ~buf : unit =
-  Buf.clear buf;
-  let continue = ref true in
-  while !continue do
-    self.fill_buf ();
-    if self.len = 0 then (
-      continue := false;
-      if Buf.size buf = 0 then raise End_of_file
-    );
-    let j = ref self.off in
-    while !j < self.off + self.len && Bytes.get self.bs !j <> '\n' do
-      incr j
-    done;
-    if !j - self.off < self.len then (
-      assert (Bytes.get self.bs !j = '\n');
-      (* line without '\n' *)
-      Buf.add_bytes buf self.bs self.off (!j - self.off);
-      (* consume line + '\n' *)
-      self.consume (!j - self.off + 1);
-      continue := false
-    ) else (
-      Buf.add_bytes buf self.bs self.off self.len;
-      self.consume self.len
-    )
-  done
-
-(* new stream with maximum size [max_size].
-   @param close_rec if true, closing this will also close the input stream
-   @param too_big called with read size if the max size is reached *)
-let limit_size_to ~close_rec ~max_size ~too_big (arg : t) : t =
-  let size = ref 0 in
-  let continue = ref true in
-  make ~bs:Bytes.empty
-    ~close:(fun _ -> if close_rec then arg.close ())
-    ~fill:(fun res ->
-      if res.len = 0 && !continue then (
-        arg.fill_buf ();
-        res.bs <- arg.bs;
-        res.off <- arg.off;
-        res.len <- arg.len
-      ) else (
-        arg.bs <- Bytes.empty;
-        arg.off <- 0;
-        arg.len <- 0
-      ))
-    ~consume:(fun res n ->
-      size := !size + n;
-      if !size > max_size then (
-        continue := false;
-        too_big !size
-      ) else (
-        arg.consume n;
-        res.off <- res.off + n;
-        res.len <- res.len - n
-      ))
-    ()
-
-(* read exactly [size] bytes from the stream *)
-let read_exactly ~close_rec ~size ~too_short (arg : t) : t =
-  if size = 0 then
-    empty
-  else (
-    let size = ref size in
-    make ~bs:Bytes.empty
-      ~fill:(fun res ->
-        (* must not block on [arg] if we're done *)
-        if !size = 0 then (
-          res.bs <- Bytes.empty;
-          res.off <- 0;
-          res.len <- 0
-        ) else (
-          arg.fill_buf ();
-          res.bs <- arg.bs;
-          res.off <- arg.off;
-          let len = min arg.len !size in
-          if len = 0 && !size > 0 then too_short !size;
-          res.len <- len
-        ))
-      ~close:(fun _res ->
-        (* close underlying stream if [close_rec] *)
-        if close_rec then arg.close ();
-        size := 0)
-      ~consume:(fun res n ->
-        let n = min n !size in
-        size := !size - n;
-        arg.consume n;
-        res.off <- res.off + n;
-        res.len <- res.len - n)
-      ()
-  )
-
-let read_line ?(buf = Buf.create ()) self : string =
-  read_line_into self ~buf;
-  Buf.contents buf
-
-let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
-  let first = ref true in
-  let read_next_chunk_len () : int =
-    if !first then
-      first := false
-    else (
-      let line = read_line ~buf bs in
-      if String.trim line <> "" then raise (fail "expected crlf between chunks")
-    );
-    let line = read_line ~buf bs in
-    (* parse chunk length, ignore extensions *)
-    let chunk_size =
-      if String.trim line = "" then
-        0
-      else (
-        try
-          let off = ref 0 in
-          let n = Tiny_httpd_parse_.pos_hex line off in
-          n
-        with _ ->
-          raise (fail (spf "cannot read chunk size from line %S" line))
-      )
-    in
-    chunk_size
-  in
-  let refill = ref true in
-  let chunk_size = ref 0 in
-  make
-    ~bs:(Bytes.create (16 * 4096))
-    ~fill:(fun self ->
-      (* do we need to refill? *)
-      if self.len = 0 then (
-        if !chunk_size = 0 && !refill then chunk_size := read_next_chunk_len ();
-        self.off <- 0;
-        self.len <- 0;
-        if !chunk_size > 0 then (
-          (* read the whole chunk, or [Bytes.length bytes] of it *)
-          let to_read = min !chunk_size (Bytes.length self.bs) in
-          read_exactly_
-            ~too_short:(fun () -> raise (fail "chunk is too short"))
-            bs self.bs to_read;
-          self.len <- to_read;
-          chunk_size := !chunk_size - to_read
-        ) else
-          refill := false (* stream is finished *)
-      ))
-    ~consume:(fun self n ->
-      self.off <- self.off + n;
-      self.len <- self.len - n)
-    ~close:(fun self ->
-      (* close this overlay, do not close underlying stream *)
-      self.len <- 0;
-      refill := false)
-    ()
-
-let output_chunked' ?buf (oc : IO.Output.t) (self : t) : unit =
-  let oc' = IO.Output.chunk_encoding ?buf oc ~close_rec:false in
-  match to_chan' oc' self with
-  | () -> IO.Output.close oc'
-  | exception e ->
-    let bt = Printexc.get_raw_backtrace () in
-    IO.Output.close oc';
-    Printexc.raise_with_backtrace e bt
-
-(* print a stream as a series of chunks *)
-let output_chunked ?buf (oc : out_channel) (self : t) : unit =
-  output_chunked' ?buf (IO.Output.of_out_channel oc) self
diff --git a/src/Tiny_httpd_stream.mli b/src/Tiny_httpd_stream.mli
deleted file mode 100644
index a5b5636d..00000000
--- a/src/Tiny_httpd_stream.mli
+++ /dev/null
@@ -1,159 +0,0 @@
-(** Byte streams.
-
-    Streams are used to represent a series of bytes that can arrive progressively.
-    For example, an uploaded file will be sent as a series of chunks.
-
-    These used to live in {!Tiny_httpd} but are now in their own module.
-    @since 0.12 *)
-
-type hidden
-(** Type used to make {!t} unbuildable via a record literal. Use {!make} instead. *)
-
-type t = {
-  mutable bs: bytes;  (** The bytes *)
-  mutable off: int;  (** Beginning of valid slice in {!bs} *)
-  mutable len: int;
-      (** Length of valid slice in {!bs}. If [len = 0] after
-      a call to {!fill}, then the stream is finished. *)
-  fill_buf: unit -> unit;
-      (** See the current slice of the internal buffer as [bytes, i, len],
-      where the slice is [bytes[i] .. [bytes[i+len-1]]].
-      Can block to refill the buffer if there is currently no content.
-      If [len=0] then there is no more data. *)
-  consume: int -> unit;
-      (** Consume [n] bytes from the buffer.
-      This should only be called with [n <= len]. *)
-  close: unit -> unit;  (** Close the stream. *)
-  _rest: hidden;  (** Use {!make} to build a stream. *)
-}
-(** A buffered stream, with a view into the current buffer (or refill if empty),
-    and a function to consume [n] bytes.
-
-    The point of this type is that it gives the caller access to its internal buffer
-    ([bs], with the slice [off,len]). This is convenient for things like line
-    reading where one needs to peek ahead.
-
-    Some core invariant for this type of stream are:
-      - [off,len] delimits a valid slice in [bs] (indices: [off, off+1, … off+len-1])
-      - if [fill_buf()] was just called, then either [len=0] which indicates the end
-        of stream; or [len>0] and the slice contains some data.
-
-    To actually move forward in the stream, you can call [consume n]
-    to consume [n] bytes (where [n <= len]). If [len] gets to [0], calling
-    [fill_buf()] is required, so it can try to obtain a new slice.
-
-    To emulate a classic OCaml reader with a [read: bytes -> int -> int -> int] function,
-    the simplest is:
-
-    {[
-    let read (self:t) buf offset max_len : int =
-      self.fill_buf();
-      let len = min max_len self.len in
-      if len > 0 then (
-        Bytes.blit self.bs self.off buf offset len;
-        self.consume len;
-      );
-      len
-
-    ]}
-*)
-
-val close : t -> unit
-(** Close stream *)
-
-val empty : t
-(** Stream with 0 bytes inside *)
-
-val of_input : ?buf_size:int -> Tiny_httpd_io.Input.t -> t
-(** Make a buffered stream from the given channel.
-    @since 0.14 *)
-
-val of_chan : ?buf_size:int -> in_channel -> t
-(** Make a buffered stream from the given channel. *)
-
-val of_chan_close_noerr : ?buf_size:int -> in_channel -> t
-(** Same as {!of_chan} but the [close] method will never fail. *)
-
-val of_fd : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t
-(** Make a buffered stream from the given file descriptor. *)
-
-val of_fd_close_noerr : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t
-(** Same as {!of_fd} but the [close] method will never fail. *)
-
-val of_bytes : ?i:int -> ?len:int -> bytes -> t
-(** A stream that just returns the slice of bytes starting from [i]
-    and of length [len]. *)
-
-val of_string : string -> t
-
-val iter : (bytes -> int -> int -> unit) -> t -> unit
-(** Iterate on the chunks of the stream
-    @since 0.3 *)
-
-val to_chan : out_channel -> t -> unit
-(** Write the stream to the channel.
-    @since 0.3 *)
-
-val to_chan' : Tiny_httpd_io.Output.t -> t -> unit
-(** Write to the IO channel.
-    @since 0.14 *)
-
-val to_writer : t -> Tiny_httpd_io.Writer.t
-(** Turn this stream into a writer.
-    @since 0.14 *)
-
-val make :
-  ?bs:bytes ->
-  ?close:(t -> unit) ->
-  consume:(t -> int -> unit) ->
-  fill:(t -> unit) ->
-  unit ->
-  t
-(** [make ~fill ()] creates a byte stream.
-    @param fill is used to refill the buffer, and is called initially.
-    @param close optional closing.
-    @param init_size size of the buffer.
-*)
-
-val with_file : ?buf_size:int -> string -> (t -> 'a) -> 'a
-(** Open a file with given name, and obtain an input stream
-    on its content. When the function returns, the stream (and file) are closed. *)
-
-val read_line : ?buf:Tiny_httpd_buf.t -> t -> string
-(** Read a line from the stream.
-    @param buf a buffer to (re)use. Its content will be cleared. *)
-
-val read_all : ?buf:Tiny_httpd_buf.t -> t -> string
-(** Read the whole stream into a string.
-    @param buf a buffer to (re)use. Its content will be cleared. *)
-
-val limit_size_to :
-  close_rec:bool -> max_size:int -> too_big:(int -> unit) -> t -> t
-(* New stream with maximum size [max_size].
-   @param close_rec if true, closing this will also close the input stream
-   @param too_big called with read size if the max size is reached *)
-
-val read_chunked : ?buf:Tiny_httpd_buf.t -> fail:(string -> exn) -> t -> t
-(** Convert a stream into a stream of byte chunks using
-    the chunked encoding. The size of chunks is not specified.
-    @param buf buffer used for intermediate storage.
-    @param fail used to build an exception if reading fails.
-*)
-
-val read_exactly :
-  close_rec:bool -> size:int -> too_short:(int -> unit) -> t -> t
-(** [read_exactly ~size bs] returns a new stream that reads exactly
-    [size] bytes from [bs], and then closes.
-    @param close_rec if true, closing the resulting stream also closes
-    [bs]
-    @param too_short is called if [bs] closes with still [n] bytes remaining
-*)
-
-val output_chunked : ?buf:Tiny_httpd_buf.t -> out_channel -> t -> unit
-(** Write the stream into the channel, using the chunked encoding.
-    @param buf optional buffer for chunking (since 0.14) *)
-
-val output_chunked' :
-  ?buf:Tiny_httpd_buf.t -> Tiny_httpd_io.Output.t -> t -> unit
-(** Write the stream into the channel, using the chunked encoding.
-    @since 0.14 *)
diff --git a/src/Tiny_httpd_util.ml b/src/Tiny_httpd_util.ml
deleted file mode 100644
index 73617702..00000000
--- a/src/Tiny_httpd_util.ml
+++ /dev/null
@@ -1,121 +0,0 @@
-let percent_encode ?(skip = fun _ -> false) s =
-  let buf = Buffer.create (String.length s) in
-  String.iter
-    (function
-      | c when skip c -> Buffer.add_char buf c
-      | ( ' ' | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '(' | ')' | '*' | '+'
-        | ',' | '/' | ':' | ';' | '=' | '?' | '@' | '[' | ']' | '~' ) as c ->
-        Printf.bprintf buf "%%%X" (Char.code c)
-      | c when Char.code c > 127 -> Printf.bprintf buf "%%%X" (Char.code c)
-      | c -> Buffer.add_char buf c)
-    s;
-  Buffer.contents buf
-
-let int_of_hex_nibble = function
-  | '0' .. '9' as c -> Char.code c - Char.code '0'
-  | 'a' .. 'f' as c -> 10 + Char.code c - Char.code 'a'
-  | 'A' .. 'F' as c -> 10 + Char.code c - Char.code 'A'
-  | _ -> invalid_arg "string: invalid hex"
-
-let percent_decode (s : string) : _ option =
-  let buf = Buffer.create (String.length s) in
-  let i = ref 0 in
-  try
-    while !i < String.length s do
-      match String.get s !i with
-      | '%' ->
-        if !i + 2 < String.length s then (
-          (match
-             (int_of_hex_nibble (String.get s (!i + 1)) lsl 4)
-             + int_of_hex_nibble (String.get s (!i + 2))
-           with
-          | n -> Buffer.add_char buf (Char.chr n)
-          | exception _ -> raise Exit);
-          i := !i + 3
-        ) else
-          raise Exit (* truncated *)
-      | '+' ->
-        Buffer.add_char buf ' ';
-        incr i (* for query strings *)
-      | c ->
-        Buffer.add_char buf c;
-        incr i
-    done;
-    Some (Buffer.contents buf)
-  with Exit -> None
-
-exception Invalid_query
-
-let find_q_index_ s = String.index s '?'
-
-let get_non_query_path s =
-  match find_q_index_ s with
-  | i -> String.sub s 0 i
-  | exception Not_found -> s
-
-let get_query s : string =
-  match find_q_index_ s with
-  | i -> String.sub s (i + 1) (String.length s - i - 1)
-  | exception Not_found -> ""
-
-let split_query s = get_non_query_path s, get_query s
-
-let split_on_slash s : _ list =
-  let l = ref [] in
-  let i = ref 0 in
-  let n = String.length s in
-  while !i < n do
-    match String.index_from s !i '/' with
-    | exception Not_found ->
-      if !i < n then (* last component *) l := String.sub s !i (n - !i) :: !l;
-      i := n (* done *)
-    | j ->
-      if j > !i then l := String.sub s !i (j - !i) :: !l;
-      i := j + 1
-  done;
-  List.rev !l
-
-let parse_query s : (_ list, string) result =
-  let pairs = ref [] in
-  let is_sep_ = function
-    | '&' | ';' -> true
-    | _ -> false
-  in
-  let i = ref 0 in
-  let j = ref 0 in
-  try
-    let percent_decode s =
-      match percent_decode s with
-      | Some x -> x
-      | None -> raise Invalid_query
-    in
-    let parse_pair () =
-      let eq = String.index_from s !i '=' in
-      let k = percent_decode @@ String.sub s !i (eq - !i) in
-      let v = percent_decode @@ String.sub s (eq + 1) (!j - eq - 1) in
-      pairs := (k, v) :: !pairs
-    in
-    while !i < String.length s do
-      while !j < String.length s && not (is_sep_ (String.get s !j)) do
-        incr j
-      done;
-      if !j < String.length s then (
-        assert (is_sep_ (String.get s !j));
-        parse_pair ();
-        i := !j + 1;
-        j := !i
-      ) else (
-        parse_pair ();
-        i := String.length s (* done *)
-      )
-    done;
-    Ok !pairs
-  with
-  | Invalid_argument _ | Not_found | Failure _ ->
-    Error (Printf.sprintf "error in parse_query for %S: i=%d,j=%d" s !i !j)
-  | Invalid_query -> Error ("invalid query string: " ^ s)
-
-let show_sockaddr = function
-  | Unix.ADDR_UNIX f -> f
-  | Unix.ADDR_INET (inet, port) ->
-    Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet) port
diff --git a/src/Tiny_httpd_util.mli b/src/Tiny_httpd_util.mli
deleted file mode 100644
index ac996855..00000000
--- a/src/Tiny_httpd_util.mli
+++ /dev/null
@@ -1,40 +0,0 @@
-(** {1 Some utils for writing web servers}
-
-    @since 0.2
-*)
-
-val percent_encode : ?skip:(char -> bool) -> string -> string
-(** Encode the string into a valid path following
-    https://tools.ietf.org/html/rfc3986#section-2.1
-    @param skip if provided, allows to preserve some characters, e.g. '/' in a path.
-*)
-
-val percent_decode : string -> string option
-(** Inverse operation of {!percent_encode}.
-    Can fail since some strings are not valid percent encodings. *)
-
-val split_query : string -> string * string
-(** Split a path between the path and the query
-    @since 0.5 *)
-
-val split_on_slash : string -> string list
-(** Split a string on ['/'], remove the trailing ['/'] if any.
-    @since 0.6 *)
-
-val get_non_query_path : string -> string
-(** get the part of the path that is not the query parameters.
-    @since 0.5 *)
-
-val get_query : string -> string
-(** Obtain the query part of a path.
-    @since 0.4 *)
-
-val parse_query : string -> ((string * string) list, string) result
-(** Parse a query as a list of ['&'] or [';'] separated [key=value] pairs.
-    The order might not be preserved.
-    @since 0.3
-*)
-
-val show_sockaddr : Unix.sockaddr -> string
-(** Simple printer for socket addresses.
-    @since NEXT_RELEASE *)
diff --git a/src/core/IO.ml b/src/core/IO.ml
index ba00b6ef..5130d14f 100644
--- a/src/core/IO.ml
+++ b/src/core/IO.ml
@@ -16,7 +16,7 @@ module Slice = Iostream.Slice
 module Output = struct
   include Iostream.Out_buf
 
-  class of_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
+  class of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
     (fd : Unix.file_descr) : t =
     object
       inherit t_from_output ~bytes:buf.bytes ()
@@ -203,7 +203,7 @@ module Input = struct
         close i2
     end
 
-  let iter (f : Slice.t -> unit) (self : #t) : unit =
+  let iter_slice (f : Slice.t -> unit) (self : #t) : unit =
     let continue = ref true in
     while !continue do
       let slice = self#fill_buf () in
@@ -216,14 +216,17 @@ module Input = struct
       )
     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
+    iter_slice
       (fun (slice : Slice.t) ->
         Stdlib.output oc slice.bytes slice.off slice.len)
       self
 
   let to_chan' (oc : #Iostream.Out_buf.t) (self : #t) : unit =
-    iter
+    iter_slice
       (fun (slice : Slice.t) ->
         Iostream.Out_buf.output oc slice.bytes slice.off slice.len)
       self
diff --git a/src/core/dune b/src/core/dune
index 36bcf2d8..a8983d14 100644
--- a/src/core/dune
+++ b/src/core/dune
@@ -2,11 +2,8 @@
 (library
   (name tiny_httpd_core)
   (public_name tiny_httpd.core)
-  (private_modules mime_ parse_)
+  (private_modules parse_)
   (libraries threads seq hmap iostream
-             (select mime_.ml from
-              (magic-mime -> mime_.magic.ml)
-              ( -> mime_.dummy.ml))
              (select log.ml from
               (logs -> log.logs.ml)
               (-> log.default.ml))))
diff --git a/src/core/server.ml b/src/core/server.ml
index 33bacc1a..d36173ae 100644
--- a/src/core/server.ml
+++ b/src/core/server.ml
@@ -83,11 +83,6 @@ type t = {
   buf_pool: Buf.t Pool.t;
 }
 
-let get_addr_ sock =
-  match Unix.getsockname sock with
-  | Unix.ADDR_INET (addr, port) -> addr, port
-  | _ -> invalid_arg "httpd: address is not INET"
-
 let addr (self : t) =
   match self.tcp_server with
   | None ->
@@ -281,8 +276,6 @@ let create_from ?(buf_size = 16 * 1_024) ?(middlewares = []) ~backend () : t =
   List.iter (fun (stage, m) -> add_middleware self ~stage m) middlewares;
   self
 
-let is_ipv6_str addr : bool = String.contains addr ':'
-
 let stop (self : t) =
   match self.tcp_server with
   | None -> ()
@@ -500,7 +493,7 @@ let client_handler (self : t) : IO.TCP_server.conn_handler =
 
 let is_ipv6 (self : t) =
   let (module B) = self.backend in
-  is_ipv6_str (B.init_addr ())
+  Util.is_ipv6_str (B.init_addr ())
 
 let run_exn ?(after_init = ignore) (self : t) : unit =
   let (module B) = self.backend in
diff --git a/src/core/util.ml b/src/core/util.ml
index 73617702..8a2b861d 100644
--- a/src/core/util.ml
+++ b/src/core/util.ml
@@ -119,3 +119,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/core/util.mli b/src/core/util.mli
index ac996855..1e5a20f3 100644
--- a/src/core/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/gen/gentags.ml b/src/gen/gentags.ml
deleted file mode 100644
index c23bcfbc..00000000
--- a/src/gen/gentags.ml
+++ /dev/null
@@ -1,517 +0,0 @@
-(* adapted from https://github.com/sindresorhus/html-tags (MIT licensed) *)
-
-let pf = Printf.printf
-let spf = Printf.sprintf
-
-let void =
-  [
-    "area";
-    "base";
-    "br";
-    "col";
-    "embed";
-    "hr";
-    "img";
-    "input";
-    "link";
-    "menuitem";
-    "meta";
-    "param";
-    "source";
-    "track";
-    "wbr";
-  ]
-
-let normal =
-  [
-    "a";
-    "abbr";
-    "address";
-    "area";
-    "article";
-    "aside";
-    "audio";
-    "b";
-    "base";
-    "bdi";
-    "bdo";
-    "blockquote";
-    "body";
-    "br";
-    "button";
-    "canvas";
-    "caption";
-    "cite";
-    "code";
-    "col";
-    "colgroup";
-    "data";
-    "datalist";
-    "dd";
-    "del";
-    "details";
-    "dfn";
-    "dialog";
-    "div";
-    "dl";
-    "dt";
-    "em";
-    "embed";
-    "fieldset";
-    "figcaption";
-    "figure";
-    "footer";
-    "form";
-    "h1";
-    "h2";
-    "h3";
-    "h4";
-    "h5";
-    "h6";
-    "head";
-    "header";
-    "hgroup";
-    "hr";
-    "html";
-    "i";
-    "iframe";
-    "img";
-    "input";
-    "ins";
-    "kbd";
-    "label";
-    "legend";
-    "li";
-    "link";
-    "main";
-    "map";
-    "mark";
-    "math";
-    "menu";
-    "menuitem";
-    "meta";
-    "meter";
-    "nav";
-    "noscript";
-    "object";
-    "ol";
-    "optgroup";
-    "option";
-    "output";
-    "p";
-    "param";
-    "picture";
-    "pre";
-    "progress";
-    "q";
-    "rb";
-    "rp";
-    "rt";
-    "rtc";
-    "ruby";
-    "s";
-    "samp";
-    "script";
-    "section";
-    "select";
-    "slot";
-    "small";
-    "source";
-    "span";
-    "strong";
-    "style";
-    "sub";
-    "summary";
-    "sup";
-    "svg";
-    "table";
-    "tbody";
-    "td";
-    "template";
-    "textarea";
-    "tfoot";
-    "th";
-    "thead";
-    "time";
-    "title";
-    "tr";
-    "track";
-    "u";
-    "ul";
-    "var";
-    "video";
-    "wbr";
-  ]
-  |> List.filter (fun s -> not (List.mem s void))
-
-(* obtained via:
-   {[
-     l = Array(...document.querySelectorAll('div tbody td code a')).map(
-       x => x.firstChild.textContent);
-     JSON.stringify(l)
-   ]}
-   on https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes
-*)
-let attrs =
-  [
-    "accept";
-    "accept-charset";
-    "accesskey";
-    "action";
-    "align";
-    "allow";
-    "alt";
-    "async";
-    "autocapitalize";
-    "autocomplete";
-    "autofocus";
-    "autoplay";
-    "buffered";
-    "capture";
-    "challenge";
-    "charset";
-    "checked";
-    "cite";
-    "class";
-    "code";
-    "codebase";
-    "cols";
-    "colspan";
-    "content";
-    "contenteditable";
-    "contextmenu";
-    "controls";
-    "coords";
-    "crossorigin";
-    "csp";
-    "data";
-    "data-*";
-    "datetime";
-    "decoding";
-    "default";
-    "defer";
-    "dir";
-    "dirname";
-    "disabled";
-    "download";
-    "draggable";
-    "enctype";
-    "enterkeyhint";
-    "for";
-    "form";
-    "formaction";
-    "formenctype";
-    "formmethod";
-    "formnovalidate";
-    "formtarget";
-    "headers";
-    "hidden";
-    "high";
-    "href";
-    "hreflang";
-    "http-equiv";
-    "icon";
-    "id";
-    "importance";
-    "integrity";
-    "ismap";
-    "itemprop";
-    "keytype";
-    "kind";
-    "label";
-    "lang";
-    "language";
-    "list";
-    "loop";
-    "low";
-    "manifest";
-    "max";
-    "maxlength";
-    "minlength";
-    "media";
-    "method";
-    "min";
-    "multiple";
-    "muted";
-    "name";
-    "novalidate";
-    "open";
-    "optimum";
-    "pattern";
-    "ping";
-    "placeholder";
-    "poster";
-    "preload";
-    "radiogroup";
-    "readonly";
-    "referrerpolicy";
-    "rel";
-    "required";
-    "reversed";
-    "rows";
-    "rowspan";
-    "sandbox";
-    "scope";
-    "scoped";
-    "selected";
-    "shape";
-    "size";
-    "sizes";
-    "slot";
-    "span";
-    "spellcheck";
-    "src";
-    "srcdoc";
-    "srclang";
-    "srcset";
-    "start";
-    "step";
-    "style";
-    "summary";
-    "tabindex";
-    "target";
-    "title";
-    "translate";
-    "Text";
-    "type";
-    "usemap";
-    "value";
-    "width";
-    "wrap";
-  ]
-
-let prelude =
-  {|
-(** Output for HTML combinators.
-
-    This output type is used to produce a string reasonably efficiently from
-    a tree of combinators.
-
-    {b NOTE}: this is experimental and an unstable API.
-
-    @since 0.12
-    @open *)
-module Out : sig
-  type t
-  val create_of_buffer : Buffer.t -> t
-  val create_of_out: Tiny_httpd_io.Output.t -> t
-  val flush : t -> unit
-  val add_char : t -> char -> unit
-  val add_string : t -> string -> unit
-  val add_format_nl : t -> unit
-  val with_no_format_nl : t -> (unit -> 'a) -> 'a
-end = struct
-  module IO = Tiny_httpd_io
-  type t = {
-    out: IO.Output.t;
-    mutable fmt_nl: bool; (* if true, we print [\n] around tags to format the html *)
-  }
-  let create_of_out out = {out; fmt_nl=true}
-  let create_of_buffer buf : t = create_of_out (IO.Output.of_buffer buf)
-  let[@inline] flush self : unit = IO.Output.flush self.out
-  let[@inline] add_char self c = IO.Output.output_char self.out c
-  let[@inline] add_string self s = IO.Output.output_string self.out s
-  let[@inline] add_format_nl self = if self.fmt_nl then add_char self '\n'
-  let with_no_format_nl self f =
-    if self.fmt_nl then (
-      self.fmt_nl <- false;
-      try let x=f() in self.fmt_nl <- true; x with e -> self.fmt_nl <- true; raise e
-    ) else f()
-end
-
-type attribute = string * string
-(** An attribute, i.e. a key/value pair *)
-
-type elt = Out.t -> unit
-(** A html element. It is represented by its output function, so we
-    can directly print it. *)
-
-type void = ?if_:bool -> attribute list -> elt
-(** Element without children. *)
-
-type nary = ?if_:bool -> attribute list -> elt list -> elt
-(** Element with children, represented as a list.
-    @param if_ if false, do not print anything (default true) *)
-
-(** A chunk of sub-elements, possibly empty.
-    @inline *)
-type sub_elt = [ `E of elt | `L of elt list | `S of elt Seq.t | `Nil]
-
-type nary' = ?if_:bool -> attribute list -> sub_elt list -> elt
-(** Element with children, represented as a list of {!sub_elt} to be flattened
-    @param if_ if false, do not print anything (default true) *)
-
-(**/**)
-module Helpers_ = struct
-
-(** Escape string so it can be safely embedded in HTML text. *)
-let _str_escape (out:Out.t) (s:string) : unit =
-  String.iter (function
-    | '<' -> Out.add_string out "<"
-    | '>' -> Out.add_string out ">"
-    | '&' -> Out.add_string out "&"
-    | '"' -> Out.add_string out """
-    | '\'' -> Out.add_string out "'"
-    | c -> Out.add_char out c)
-  s
-
-(** Print the value part of an attribute *)
-let _attr_escape (out:Out.t) (s:string) =
-  Out.add_char out '"';
-  _str_escape out s;
-  Out.add_char out '"'
-
-(** Output a list of attributes. *)
-let _write_attrs (out:Out.t) (l:attribute list) : unit =
-  List.iter
-    (fun (k,v) ->
-      Out.add_char out ' ';
-      Out.add_string out k;
-      Out.add_char out '=';
-      _attr_escape out v)
-    l
-
-(** Write sub-elements of a {!nary'} element, returns [true] iff
-    at least one sub-element was written. *)
-let _write_subs (out:Out.t) (l:sub_elt list) : bool =
-  let has_sub = ref false in
-  let prepend_white () = has_sub := true; Out.add_format_nl out; in
-  let emit1 = function
-    | `E x -> prepend_white(); x out
-    | `L l -> List.iter (fun e -> prepend_white(); e out) l
-    | `S l -> Seq.iter (fun e -> prepend_white(); e out) l
-    | `Nil -> ()
-  in
-  List.iter emit1 l;
-  !has_sub
-
-(** Write a tag, with its attributes.
-    @param void if true, end with "/>", otherwise end with ">" *)
-let _write_tag_attrs ~void (out:Out.t) (tag:string) (attrs:attribute list) : unit =
-  Out.add_string out "<";
-  Out.add_string out tag;
-  _write_attrs out attrs;
-  if void then Out.add_string out "/>" else Out.add_string out ">"
-
-end
-open Helpers_
-(**/**)
-
-(** Sub-element with a single element inside. *)
-let[@inline] sub_e (elt:elt) : sub_elt = `E elt
-
-(** Sub-element with a list of items inside. *)
-let[@inline] sub_l (l:elt list) : sub_elt = `L l
-
-(** Sub-element with a sequence ({!Seq.t}) of items inside. *)
-let[@inline] sub_seq (l:elt Seq.t) : sub_elt = `S l
-
-(** Helper to build a {!Seq.t} from an array. *)
-let seq_of_array (a:_ array) : _ Seq.t =
-  let rec loop i () =
-    if i=Array.length a then Seq.Nil
-    else Seq.Cons (a.(i), loop (i+1))
-  in loop 0
-
-(** Sub-element with nothing inside. Useful in conditionals, when one
-    decides not to emit a sub-element at all. *)
-let sub_empty : sub_elt = `Nil
-
-(** Emit a string value, which will be escaped. *)
-let txt (txt:string) : elt = fun out -> _str_escape out txt
-
-(** Formatted version of {!txt} *)
-let txtf fmt = Format.kasprintf (fun s -> fun out -> _str_escape out s) fmt
-
-(** Emit raw HTML. Caution, this can lead to injection vulnerabilities,
-  never use with text that comes from untrusted users. *)
-let raw_html (s:string) : elt = fun out -> Out.add_string out s
-|}
-
-let oname = function
-  | "object" -> "object_"
-  | "class" -> "class_"
-  | "method" -> "method_"
-  | "data-*" -> "data_star"
-  | "for" -> "for_"
-  | "open" -> "open_"
-  | "Text" -> "text"
-  | "type" -> "type_"
-  | name ->
-    String.map
-      (function
-        | '-' -> '_'
-        | c -> c)
-      name
-
-let emit_void name =
-  let oname = oname name in
-  pf
-    "(** tag %S, see \
-     {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
-    name name;
-  pf "let %s : void = fun ?(if_=true) attrs out ->\n" oname;
-  pf "  if if_ then (\n";
-  pf "    _write_tag_attrs ~void:true out %S attrs;\n" name;
-  pf "  )";
-  pf "\n\n";
-  ()
-
-let emit_normal name =
-  let oname = oname name in
-
-  pf
-    "(** tag %S, see \
-     {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
-    name name;
-  pf "let %s : nary = fun ?(if_=true) attrs sub out ->\n" oname;
-  pf "  if if_ then (\n";
-  (* for 
, newlines actually matter *)
-  if name = "pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
-  pf "    _write_tag_attrs ~void:false out %S attrs;\n" name;
-  pf "    List.iter (fun sub -> Out.add_format_nl out; sub out) sub;\n";
-  pf "    if sub <> [] then Out.add_format_nl out;\n";
-  pf "    Out.add_string out \"\")" name;
-  pf "\n\n";
-
-  (* block version *)
-  let oname = oname ^ "'" in
-  pf
-    "(** tag %S, see \
-     {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
-    name name;
-  pf "let %s : nary' = fun ?(if_=true) attrs l out ->\n" oname;
-  pf "  if if_ then (\n";
-  if name = "pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
-  pf "    _write_tag_attrs ~void:false out %S attrs;\n" name;
-  pf "    let has_sub = _write_subs out l in\n";
-  pf "    if has_sub then Out.add_format_nl out;\n";
-  pf "    Out.add_string out \"\")" name;
-  pf "\n\n";
-
-  ()
-
-let doc_attrs =
-  {|Attributes.
-
-This module contains combinator for the standard attributes.
-One can also just use a pair of strings. |}
-
-let emit_attr name =
-  let oname = oname name in
-  pf "  (** Attribute %S. *)\n" name;
-  pf "  let %s : t = fun v -> %S, v\n" oname name;
-  pf "\n"
-
-let () =
-  pf "%s\n" prelude;
-  List.iter emit_void void;
-  List.iter emit_normal normal;
-  pf "(** %s *)\n" doc_attrs;
-  pf "module A = struct\n";
-  pf "  type t = string -> attribute\n";
-  pf "  (** Attribute builder *)\n";
-  pf "\n";
-  List.iter emit_attr attrs;
-  pf "end\n";
-  ()
diff --git a/src/gen/mkshims.ml b/src/gen/mkshims.ml
deleted file mode 100644
index a49f1ab7..00000000
--- a/src/gen/mkshims.ml
+++ /dev/null
@@ -1,41 +0,0 @@
-let atomic_before_412 =
-  {|
-  type 'a t = {mutable x: 'a}
-  let[@inline] make x = {x}
-  let[@inline] get {x} = x
-  let[@inline] set r x = r.x <- x
-  let[@inline] exchange r x =
-    let y = r.x in
-    r.x <- x;
-    y
-
-  let[@inline] compare_and_set r seen v =
-    if r.x == seen then (
-      r.x <- v;
-      true
-    ) else false
-
-  let[@inline] fetch_and_add r x =
-    let v = r.x in
-    r.x <- x + r.x;
-    v
-
-  let[@inline] incr r = r.x <- 1 + r.x
-  let[@inline] decr r = r.x <- r.x - 1
-  |}
-
-let atomic_after_412 = {|include Atomic|}
-
-let write_file file s =
-  let oc = open_out file in
-  output_string oc s;
-  close_out oc
-
-let () =
-  let version = Scanf.sscanf Sys.ocaml_version "%d.%d.%s" (fun x y _ -> x, y) in
-  print_endline
-    (if version >= (4, 12) then
-      atomic_after_412
-    else
-      atomic_before_412);
-  ()
diff --git a/src/html/Tiny_httpd_html.ml b/src/html/Tiny_httpd_html.ml
index 0ae659d7..8ed797f6 100644
--- a/src/html/Tiny_httpd_html.ml
+++ b/src/html/Tiny_httpd_html.ml
@@ -6,8 +6,6 @@
     @since 0.12
 *)
 
-module IO = Tiny_httpd_io
-
 include Html_
 (** @inline *)
 
@@ -61,5 +59,5 @@ let to_writer ?top (self : elt) : IO.Writer.t =
 
 (** Convert a HTML element to a stream. This might just convert
     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
index c4648a3b..64386122 100644
--- a/src/html/dune
+++ b/src/html/dune
@@ -3,7 +3,8 @@
 (library
   (name tiny_httpd_html)
   (public_name tiny_httpd.html)
-  (libraries seq tiny_httpd.html))
+  (flags :standard -open Tiny_httpd_core)
+  (libraries seq tiny_httpd.core))
 
 (rule
  (targets html_.ml)
diff --git a/src/html/gen/gentags.ml b/src/html/gen/gentags.ml
index c23bcfbc..2736b796 100644
--- a/src/html/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/Tiny_httpd_dir.ml b/src/unix/dir.ml
similarity index 87%
rename from src/Tiny_httpd_dir.ml
rename to src/unix/dir.ml
index c619c217..d596a78f 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,51 @@ 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 ~max_size:config.max_upload_size req
         in
-        Tiny_httpd_stream.iter write req.S.Request.body;
+        IO.Input.iter write req.Request.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 +269,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,17 +295,17 @@ 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 =
@@ -315,13 +315,13 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
                 [ "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 +330,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 +437,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/core/mime_.dummy.ml b/src/unix/mime_.dummy.ml
similarity index 100%
rename from src/core/mime_.dummy.ml
rename to src/unix/mime_.dummy.ml
diff --git a/src/core/mime_.magic.ml b/src/unix/mime_.magic.ml
similarity index 100%
rename from src/core/mime_.magic.ml
rename to src/unix/mime_.magic.ml
diff --git a/src/core/mime_.mli b/src/unix/mime_.mli
similarity index 100%
rename from src/core/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..37f5f921
--- /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.info (fun k ->
+                k "t[%d]: serving new client on %s"
+                  (Thread.id @@ Thread.self ())
+                  (Util.show_sockaddr client_addr));
+
+            if self.masksigpipe then
+              ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list);
+            Unix.set_nonblock client_sock;
+            Unix.setsockopt client_sock Unix.TCP_NODELAY true;
+            Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout);
+            Unix.(setsockopt_float client_sock SO_SNDTIMEO self.timeout);
+
+            Pool.with_resource self.slice_pool @@ fun ic_buf ->
+            Pool.with_resource self.slice_pool @@ fun oc_buf ->
+            let closed = ref false in
+
+            let oc =
+              new IO.Output.of_unix_fd
+                ~close_noerr:true ~closed ~buf:oc_buf client_sock
+            in
+            let ic =
+              IO.Input.of_unix_fd ~close_noerr:true ~closed ~buf:ic_buf
+                client_sock
+            in
+            handle.handle ~client_addr ic oc
+          in
+
+          Unix.set_nonblock sock;
+          while self.running do
+            match Unix.accept sock with
+            | client_sock, client_addr ->
+              (* limit concurrency *)
+              Sem.acquire 1 self.sem_max_connections;
+              (* Block INT/HUP while cloning to avoid children handling them.
+                 When thread gets them, our Unix.accept raises neatly. *)
+              ignore Unix.(sigprocmask SIG_BLOCK Sys.[ sigint; sighup ]);
+              self.new_thread (fun () ->
+                  try
+                    handle_client_unix_ client_sock client_addr;
+                    Log.info (fun k ->
+                        k "t[%d]: done with client on %s, exiting"
+                          (Thread.id @@ Thread.self ())
+                        @@ Util.show_sockaddr client_addr);
+                    shutdown_silent_ client_sock;
+                    close_silent_ client_sock;
+                    Sem.release 1 self.sem_max_connections
+                  with e ->
+                    let bt = Printexc.get_raw_backtrace () in
+                    shutdown_silent_ client_sock;
+                    close_silent_ client_sock;
+                    Sem.release 1 self.sem_max_connections;
+                    Log.error (fun k ->
+                        k
+                          "@[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/tiny_httpd.opam b/tiny_httpd.opam
index a5224f40..ffd43a56 100644
--- a/tiny_httpd.opam
+++ b/tiny_httpd.opam
@@ -15,6 +15,7 @@ depends: [
   "seq"
   "base-threads"
   "result"
+  "hmap"
   "ocaml" {>= "4.08"}
   "odoc" {with-doc}
   "logs" {with-test}
diff --git a/vendor/iostream b/vendor/iostream
new file mode 160000
index 00000000..bb03b78f
--- /dev/null
+++ b/vendor/iostream
@@ -0,0 +1 @@
+Subproject commit bb03b78fab03e9eb7186c45d33d23735650351ec

From 0d750cd86c1832fbdf8a82080e03309173041e16 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Mon, 26 Feb 2024 14:00:58 -0500
Subject: [PATCH 04/20] fix prometheus

---
 src/Tiny_httpd.ml                        |  2 +
 src/Tiny_httpd.mli                       | 57 ++++++++++++++++++++++++
 src/bin/http_of_dir.ml                   |  4 +-
 src/core/dune                            |  4 +-
 src/core/pool.ml                         |  2 +-
 src/prometheus/common_.ml                |  3 --
 src/prometheus/common_p_.ml              |  3 ++
 src/prometheus/dune                      |  5 ++-
 src/prometheus/tiny_httpd_prometheus.ml  | 21 +++++----
 src/prometheus/tiny_httpd_prometheus.mli |  6 +--
 10 files changed, 83 insertions(+), 24 deletions(-)
 delete mode 100644 src/prometheus/common_.ml
 create mode 100644 src/prometheus/common_p_.ml

diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml
index 422a7cdb..6263199a 100644
--- a/src/Tiny_httpd.ml
+++ b/src/Tiny_httpd.ml
@@ -6,6 +6,8 @@ module Html = Tiny_httpd_html
 module IO = Tiny_httpd_core.IO
 module Pool = Tiny_httpd_core.Pool
 module Log = Tiny_httpd_core.Log
+module Server = Tiny_httpd_core.Server
+include Server
 
 open struct
   let get_max_connection_ ?(max_connections = 64) () : int =
diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli
index 167b5873..2eb3afbb 100644
--- a/src/Tiny_httpd.mli
+++ b/src/Tiny_httpd.mli
@@ -108,6 +108,63 @@ module Pool = Tiny_httpd_core.Pool
 
 module Dir = Tiny_httpd_unix.Dir
 
+(** {2 HTML combinators} *)
+
 module Html = Tiny_httpd_html
 (** Alias to {!Tiny_httpd_html}
     @since 0.12 *)
+
+(** {2 Main server types} *)
+
+module Server = Tiny_httpd_core.Server
+
+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/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/core/dune b/src/core/dune
index a8983d14..a04707ef 100644
--- a/src/core/dune
+++ b/src/core/dune
@@ -2,14 +2,14 @@
 (library
   (name tiny_httpd_core)
   (public_name tiny_httpd.core)
-  (private_modules parse_)
+  (private_modules parse_ common_)
   (libraries threads seq hmap iostream
              (select log.ml from
               (logs -> log.logs.ml)
               (-> log.default.ml))))
 
 (rule
- (targets Tiny_httpd_atomic_.ml)
+ (targets Atomic_.ml)
  (deps
   (:bin ./gen/mkshims.exe))
  (action
diff --git a/src/core/pool.ml b/src/core/pool.ml
index 1a441944..fc9a0461 100644
--- a/src/core/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/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

From 22f158ccd84919f80857a925a4a00eb4978e7b5f Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Mon, 26 Feb 2024 14:06:01 -0500
Subject: [PATCH 05/20] fix websocket

---
 src/ws/{common_.ml => common_ws_.ml} |  0
 src/ws/dune                          |  5 ++--
 src/ws/tiny_httpd_ws.ml              | 41 ++++++++++++++--------------
 src/ws/tiny_httpd_ws.mli             |  7 ++---
 4 files changed, 25 insertions(+), 28 deletions(-)
 rename src/ws/{common_.ml => common_ws_.ml} (100%)

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..94c0decb 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 ()
+
+      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.

From adf4c6815f3941928b1fd4b7219277b312411ccc Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Mon, 26 Feb 2024 15:48:10 -0500
Subject: [PATCH 06/20] finish refactor

---
 dune-project                       |   1 +
 src/camlzip/Tiny_httpd_camlzip.ml  | 188 ++++++-----------------------
 src/camlzip/Tiny_httpd_camlzip.mli |   4 +-
 src/camlzip/dune                   |   4 +-
 src/core/IO.ml                     |  42 +++----
 src/core/buf.ml                    |   1 +
 src/core/buf.mli                   |   1 +
 src/core/request.ml                |  25 ++--
 src/core/request.mli               |  19 ++-
 src/core/response.ml               |   4 +-
 src/core/response.mli              |   2 +-
 src/core/server.ml                 |  47 ++++----
 src/html/Tiny_httpd_html.ml        |   7 +-
 src/ws/tiny_httpd_ws.ml            |   4 +-
 vendor/iostream                    |   2 +-
 15 files changed, 125 insertions(+), 226 deletions(-)

diff --git a/dune-project b/dune-project
index 468a58dd..370ef50a 100644
--- a/dune-project
+++ b/dune-project
@@ -36,5 +36,6 @@
   (depends
     (tiny_httpd (= :version))
     (camlzip (>= 1.06))
+    iostream-camlzip
     (logs :with-test)
     (odoc :with-doc)))
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
index 5130d14f..afcdc8df 100644
--- a/src/core/IO.ml
+++ b/src/core/IO.ml
@@ -109,7 +109,7 @@ module Input = struct
       (fd : Unix.file_descr) : t =
     let eof = ref false in
     object
-      inherit Iostream.In_buf.t_from_refill ~buf ()
+      inherit Iostream.In_buf.t_from_refill ~bytes:buf.bytes ()
 
       method private refill (slice : Slice.t) =
         if not !eof then (
@@ -137,7 +137,7 @@ module Input = struct
           if slice.len = 0 then eof := true
         )
 
-      method! close () =
+      method close () =
         if not !closed then (
           closed := true;
           eof := true;
@@ -150,13 +150,13 @@ module Input = struct
 
   let of_slice (slice : Slice.t) : t =
     object
-      inherit Iostream.In_buf.t_from_refill ~buf:slice ()
+      inherit Iostream.In_buf.t_from_refill ~bytes:slice.bytes ()
 
       method private refill (slice : Slice.t) =
         slice.off <- 0;
         slice.len <- 0
 
-      method! close () = ()
+      method close () = ()
     end
 
   (** Read into the given slice.
@@ -198,7 +198,7 @@ module Input = struct
         slice.off <- 0;
         input_rec slice
 
-      method! close () =
+      method close () =
         close i1;
         close i2
     end
@@ -225,10 +225,10 @@ module Input = struct
         Stdlib.output oc slice.bytes slice.off slice.len)
       self
 
-  let to_chan' (oc : #Iostream.Out_buf.t) (self : #t) : unit =
+  let to_chan' (oc : #Iostream.Out.t) (self : #t) : unit =
     iter_slice
       (fun (slice : Slice.t) ->
-        Iostream.Out_buf.output oc slice.bytes slice.off slice.len)
+        Iostream.Out.output oc slice.bytes slice.off slice.len)
       self
 
   let read_all_using ~buf (self : #t) : string =
@@ -299,11 +299,10 @@ module Input = struct
    @param close_rec if true, closing this will also close the input stream *)
   let limit_size_to ~close_rec ~max_size ~(bytes : bytes) (arg : t) : t =
     let remaining_size = ref max_size in
-    let slice = Slice.of_bytes bytes in
 
     object
-      inherit Iostream.In_buf.t_from_refill ~buf:slice ()
-      method! close () = if close_rec then close arg
+      inherit Iostream.In_buf.t_from_refill ~bytes ()
+      method close () = if close_rec then close arg
 
       method private refill slice =
         if slice.len = 0 then
@@ -324,12 +323,11 @@ module Input = struct
    @param close_rec if true, closing this will also close the input stream *)
   let reading_exactly ~close_rec ~size ~(bytes : bytes) (arg : t) : t =
     let remaining_size = ref size in
-    let slice = Slice.of_bytes bytes in
 
     object
-      inherit Iostream.In_buf.t_from_refill ~buf:slice ()
+      inherit Iostream.In_buf.t_from_refill ~bytes ()
 
-      method! close () =
+      method close () =
         if !remaining_size > 0 then skip arg !remaining_size;
         if close_rec then close arg
 
@@ -346,9 +344,11 @@ module Input = struct
           )
     end
 
-  let read_chunked ~(buf : Slice.t) ~fail (bs : #t) : t =
+  let read_chunked ~(bytes : bytes) ~fail (bs : #t) : t =
     let first = ref true in
-    let line_buf = Buf.create ~size:128 () 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
@@ -377,7 +377,7 @@ module Input = struct
     let chunk_size = ref 0 in
 
     object
-      inherit t_from_refill ~buf ()
+      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 ();
@@ -395,10 +395,7 @@ module Input = struct
           (* stream is finished *)
           eof := true
 
-      method! close () =
-        (* do not close underlying stream *)
-        eof := true;
-        ()
+      method close () = eof := true (* do not close underlying stream *)
     end
 
   (** Output a stream using chunked encoding *)
@@ -435,14 +432,15 @@ module Writer = struct
   let[@inline] make ~write () : t = { write }
 
   (** Write into the channel. *)
-  let[@inline] write (oc : Output.t) (self : t) : unit = self.write oc
+  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 = Output.output_string oc str in
+    let write oc = Iostream.Out.output_string oc str in
     { write }
 
   let[@inline] of_input (ic : #Input.t) : t =
diff --git a/src/core/buf.ml b/src/core/buf.ml
index fcc89933..5824946f 100644
--- a/src/core/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/core/buf.mli b/src/core/buf.mli
index e5ca90c1..dbbbb7ca 100644
--- a/src/core/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/request.ml b/src/core/request.ml
index 1a5c19b7..df0cd1e0 100644
--- a/src/core/request.ml
+++ b/src/core/request.ml
@@ -24,6 +24,9 @@ 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
@@ -64,9 +67,9 @@ let pp out self : unit =
     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 : #IO.Input.t) : IO.Input.t =
+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 ~buf ~fail:(fun s -> Bad_req (400, s)) bs
+  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);
@@ -146,8 +149,8 @@ let parse_req_start ~client_addr ~get_time_s ~buf (bs : IO.Input.t) :
 
 (* parse body, given the headers.
    @param tr_stream a transformation of the input stream. *)
-let parse_body_ ~tr_stream ~buf (req : IO.Input.t t) : IO.Input.t t resp_result
-    =
+let parse_body_ ~tr_stream ~bytes (req : IO.Input.t t) :
+    IO.Input.t t resp_result =
   try
     let size =
       match Headers.get_exn "Content-Length" req.headers |> int_of_string with
@@ -162,7 +165,9 @@ let parse_body_ ~tr_stream ~buf (req : IO.Input.t t) : IO.Input.t t resp_result
         read_exactly ~size ~bytes @@ tr_stream req.body
       | Some "chunked" ->
         (* body sent by chunks *)
-        let bs : IO.Input.t = read_stream_chunked_ ~buf @@ tr_stream req.body in
+        let bs : IO.Input.t =
+          read_stream_chunked_ ~bytes @@ tr_stream req.body
+        in
         if size > 0 then (
           let bytes = Bytes.create 4096 in
           limit_body_size_ ~max_size:size ~bytes bs
@@ -176,11 +181,11 @@ let parse_body_ ~tr_stream ~buf (req : IO.Input.t t) : IO.Input.t t resp_result
   | Bad_req (c, s) -> Error (c, s)
   | e -> Error (400, Printexc.to_string e)
 
-let read_body_full ?buf ?buf_size (self : IO.Input.t t) : string t =
+let read_body_full ?bytes ?buf_size (self : IO.Input.t t) : string t =
   try
     let buf =
-      match buf with
-      | Some b -> b
+      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
@@ -196,8 +201,8 @@ module Private_ = struct
   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 ?(buf = IO.Slice.create 4096) req bs : _ t =
-    parse_body_ ~tr_stream:(fun s -> s) ~buf { req with body = bs }
+  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 }
diff --git a/src/core/request.mli b/src/core/request.mli
index cf4f8368..731cfe69 100644
--- a/src/core/request.mli
+++ b/src/core/request.mli
@@ -36,6 +36,19 @@ type 'body t = private {
       @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 : Format.formatter -> string t -> unit
 (** Pretty print the request and its body. The exact format of this printing
       is not specified. *)
@@ -102,11 +115,11 @@ val limit_body_size :
       @since 0.3
   *)
 
-val read_body_full : ?buf:Buf.t -> ?buf_size:int -> IO.Input.t t -> string t
+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 buf the initial buffer (since 0.14)
+    @param bytes the initial buffer (since 0.14)
     *)
 
 (**/**)
@@ -128,7 +141,7 @@ module Private_ : sig
     unit t option
 
   val close_after_req : _ t -> bool
-  val parse_body : ?buf:IO.Slice.t -> unit t -> IO.Input.t -> IO.Input.t t
+  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
index 1bd7af66..3e2d4347 100644
--- a/src/core/response.ml
+++ b/src/core/response.ml
@@ -76,12 +76,12 @@ let pp out self : unit =
   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 =
+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
-  Buf.clear buf;
+  let buf = Buf.of_bytes bytes in
 
   (* write start of reply *)
   Printf.bprintf tmp_buffer "HTTP/1.1 %d %s\r\n" self.code
diff --git a/src/core/response.mli b/src/core/response.mli
index 610faed5..6ddf08b8 100644
--- a/src/core/response.mli
+++ b/src/core/response.mli
@@ -112,7 +112,7 @@ val pp : Format.formatter -> t -> unit
 
 module Private_ : sig
   val make_void_force_ : ?headers:Headers.t -> code:int -> unit -> t
-  val output_ : buf:Buf.t -> IO.Output.t -> t -> unit
+  val output_ : bytes:Bytes.t -> IO.Output.t -> t -> unit
 end
 
 (**/**)
diff --git a/src/core/server.ml b/src/core/server.ml
index d36173ae..e24bed89 100644
--- a/src/core/server.ml
+++ b/src/core/server.ml
@@ -72,7 +72,6 @@ let unwrap_handler_result req = function
 type t = {
   backend: (module IO_BACKEND);
   mutable tcp_server: IO.TCP_server.t option;
-  buf_size: int;
   mutable handler: IO.Input.t Request.t -> Response.t;
       (** toplevel handler, if any *)
   mutable middlewares: (int * Middleware.t) list;  (** Global middlewares *)
@@ -80,7 +79,7 @@ type t = {
       (** sorted version of {!middlewares} *)
   mutable path_handlers: (unit Request.t -> handler_result option) list;
       (** path handlers *)
-  buf_pool: Buf.t Pool.t;
+  bytes_pool: bytes Pool.t;
 }
 
 let addr (self : t) =
@@ -169,8 +168,8 @@ 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
+      Pool.with_resource self.bytes_pool @@ fun bytes ->
+      Request.read_body_full ~bytes req
     in
     resp (f req)
   in
@@ -190,8 +189,8 @@ 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
+      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")
@@ -256,6 +255,8 @@ let add_upgrade_handler ?(accept = fun _ -> Ok ()) (self : t) route f : unit =
   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 =
@@ -263,13 +264,12 @@ let create_from ?(buf_size = 16 * 1_024) ?(middlewares = []) ~backend () : t =
       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 ())
+      bytes_pool =
+        Pool.create ~clear:clear_bytes_
+          ~mk_item:(fun () -> Bytes.create buf_size)
           ();
     }
   in
@@ -302,8 +302,8 @@ let string_as_list_contains_ (s : string) (sub : string) : bool =
 
 (* 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 ->
+  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 *)
@@ -336,7 +336,7 @@ let client_handle_for (self : t) ~client_addr ic oc : 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_ ~buf:buf_res oc resp
+    Response.Private_.output_ ~bytes:bytes_res oc resp
   in
 
   let handle_bad_req req e bt =
@@ -346,7 +346,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
       log_exn msg bt;
       log_response req resp
     );
-    Response.Private_.output_ ~buf:buf_res oc resp
+    Response.Private_.output_ ~bytes:bytes_res oc resp
   in
 
   let handle_upgrade req (module UP : UPGRADE_HANDLER) : unit =
@@ -368,7 +368,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
         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_ ~buf:buf_res oc resp
+        Response.Private_.output_ ~bytes:bytes_res oc resp
       | Ok (headers, handshake_st) ->
         (* send the upgrade reply *)
         let headers =
@@ -376,7 +376,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
         in
         let resp = Response.make_string ~code:101 ~headers (Ok "") in
         log_response req resp;
-        Response.Private_.output_ ~buf:buf_res oc resp;
+        Response.Private_.output_ ~bytes:bytes_res oc resp;
 
         UP.handle_connection client_addr handshake_st ic oc
     with e ->
@@ -388,6 +388,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
 
   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
@@ -395,7 +396,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
     | Error (c, s) ->
       (* connection error, close *)
       let res = Response.make_raw ~code:c s in
-      (try Response.Private_.output_ ~buf:buf_res oc res
+      (try Response.Private_.output_ ~bytes:bytes_res oc res
        with Sys_error _ -> ());
       continue := false
     | Ok (Some req) ->
@@ -418,7 +419,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
          (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_ ~buf:buf_res oc
+           Response.Private_.output_ ~bytes:bytes_res oc
              (Response.make_raw ~code:100 "")
          | Some s -> bad_reqf 417 "unknown expectation %s" s
          | None -> ());
@@ -432,11 +433,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
          in
 
          (* now actually read request's body into a stream *)
-         let req =
-           Request.Private_.parse_body
-             ~buf:(IO.Slice.of_bytes (Buf.bytes_slice buf))
-             req ic
-         in
+         let req = Request.Private_.parse_body ~bytes:bytes_req req ic in
 
          (* how to reply *)
          let resp r =
@@ -444,7 +441,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
              if Headers.get "connection" r.Response.headers = Some "close" then
                continue := false;
              log_response req r;
-             Response.Private_.output_ ~buf:buf_res oc 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);
@@ -466,7 +463,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
         continue := false;
         let resp = Response.make_raw ~code s in
         log_response req resp;
-        Response.Private_.output_ ~buf:buf_res oc resp
+        Response.Private_.output_ ~bytes:bytes_res oc resp
       | Upgrade _ as e -> raise e
       | e ->
         let bt = Printexc.get_raw_backtrace () in
diff --git a/src/html/Tiny_httpd_html.ml b/src/html/Tiny_httpd_html.ml
index 8ed797f6..0b1ac3f9 100644
--- a/src/html/Tiny_httpd_html.ml
+++ b/src/html/Tiny_httpd_html.ml
@@ -14,12 +14,11 @@ include 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;
-  Out.add_format_nl out;
-  Out.flush out
+  Out.add_format_nl out
 
 (** Convert a HTML element to a string.
     @param top if true, add DOCTYPE at the beginning. The top element should then
@@ -54,7 +53,7 @@ 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
diff --git a/src/ws/tiny_httpd_ws.ml b/src/ws/tiny_httpd_ws.ml
index 94c0decb..3917ef0e 100644
--- a/src/ws/tiny_httpd_ws.ml
+++ b/src/ws/tiny_httpd_ws.ml
@@ -380,13 +380,13 @@ let upgrade ic oc : _ * _ =
   let reader = Reader.create ~ic ~writer () in
   let ws_ic : IO.Input.t =
     object
-      inherit IO.Input.t_from_refill ()
+      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
+      method close () = Reader.close reader
     end
   in
   let ws_oc : IO.Output.t =
diff --git a/vendor/iostream b/vendor/iostream
index bb03b78f..668a7c22 160000
--- a/vendor/iostream
+++ b/vendor/iostream
@@ -1 +1 @@
-Subproject commit bb03b78fab03e9eb7186c45d33d23735650351ec
+Subproject commit 668a7c22c09d21293c9ce3fd8bc66b3080c525d2

From e3047a7b6a8b2e9c8aa3151644e33dbdbdfb64e7 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Mon, 26 Feb 2024 15:59:23 -0500
Subject: [PATCH 07/20] fixes

---
 src/core/IO.ml              | 10 +++++-----
 src/html/Tiny_httpd_html.ml |  3 ++-
 tiny_httpd.opam             |  1 +
 tiny_httpd_camlzip.opam     |  1 +
 4 files changed, 9 insertions(+), 6 deletions(-)

diff --git a/src/core/IO.ml b/src/core/IO.ml
index afcdc8df..03ff5919 100644
--- a/src/core/IO.ml
+++ b/src/core/IO.ml
@@ -77,18 +77,18 @@ module Output = struct
       )
     in
 
-    object (self)
+    object
       method flush () =
         write_buf ~force:true ();
-        flush self
+        flush oc
 
       method close () =
         write_buf ~force:true ();
         (* write an empty chunk to close the stream *)
-        output_string self "0\r\n";
+        output_string oc "0\r\n";
         (* write another crlf after the stream (see #56) *)
-        output_string self "\r\n";
-        self#flush ();
+        output_string oc "\r\n";
+        flush oc;
         if close_rec then close oc
 
       method output b i n =
diff --git a/src/html/Tiny_httpd_html.ml b/src/html/Tiny_httpd_html.ml
index 0b1ac3f9..af9cf45d 100644
--- a/src/html/Tiny_httpd_html.ml
+++ b/src/html/Tiny_httpd_html.ml
@@ -18,7 +18,8 @@ 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;
-  Out.add_format_nl out
+  Out.add_format_nl out;
+  Out.flush out
 
 (** Convert a HTML element to a string.
     @param top if true, add DOCTYPE at the beginning. The top element should then
diff --git a/tiny_httpd.opam b/tiny_httpd.opam
index ffd43a56..c144b511 100644
--- a/tiny_httpd.opam
+++ b/tiny_httpd.opam
@@ -16,6 +16,7 @@ depends: [
   "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}
 ]

From ec3dec6b72bde5048ab2d662526c2cc6b882d4f5 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Mon, 26 Feb 2024 16:28:31 -0500
Subject: [PATCH 08/20] wip: bugfixes

---
 examples/echo.ml       | 93 +++++++++++++++++++++---------------------
 examples/echo_ws.ml    |  8 ++--
 examples/sse_server.ml | 27 ++++++------
 examples/writer.ml     | 13 +++---
 src/Tiny_httpd.ml      |  3 ++
 src/Tiny_httpd.mli     |  2 +
 src/bin/vfs_pack.ml    |  6 +--
 src/core/IO.ml         | 88 +++++++++++++++++++--------------------
 src/core/request.ml    | 24 +++++------
 src/core/request.mli   |  4 +-
 tests/unit/dune        |  2 +-
 tests/unit/t_buf.ml    |  2 +-
 tests/unit/t_server.ml | 12 ++++--
 tests/unit/t_util.ml   | 33 +++++++--------
 14 files changed, 158 insertions(+), 159 deletions(-)

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 6263199a..85c7c3fe 100644
--- a/src/Tiny_httpd.ml
+++ b/src/Tiny_httpd.ml
@@ -2,6 +2,9 @@ module Buf = Buf
 include Server
 module Util = Util
 module Dir = Tiny_httpd_unix.Dir
+
+module type VFS = Tiny_httpd_unix.Dir.VFS
+
 module Html = Tiny_httpd_html
 module IO = Tiny_httpd_core.IO
 module Pool = Tiny_httpd_core.Pool
diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli
index 2eb3afbb..584d0188 100644
--- a/src/Tiny_httpd.mli
+++ b/src/Tiny_httpd.mli
@@ -108,6 +108,8 @@ module Pool = Tiny_httpd_core.Pool
 
 module Dir = Tiny_httpd_unix.Dir
 
+module type VFS = Tiny_httpd_unix.Dir.VFS
+
 (** {2 HTML combinators} *)
 
 module Html = Tiny_httpd_html
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/core/IO.ml b/src/core/IO.ml
index 03ff5919..525b0472 100644
--- a/src/core/IO.ml
+++ b/src/core/IO.ml
@@ -295,56 +295,51 @@ module Input = struct
     | () -> Some (Buf.contents_and_clear buf)
     | exception End_of_file -> None
 
-  (** 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 : bytes) (arg : t) : t =
-    let remaining_size = ref max_size in
+  let reading_exactly_ ~skip_on_close ~close_rec ~size (arg : t) : t =
+    let remaining_size = ref size in
 
     object
-      inherit Iostream.In_buf.t_from_refill ~bytes ()
-      method close () = if close_rec then close arg
+      method close () =
+        if !remaining_size > 0 && skip_on_close then skip arg !remaining_size;
+        if close_rec then close arg
 
-      method private refill slice =
-        if slice.len = 0 then
-          if !remaining_size > 0 then (
-            let sub = fill_buf arg in
-            let len = min sub.len !remaining_size in
+      method fill_buf () =
+        if !remaining_size > 0 then
+          fill_buf arg
+        else
+          Slice.empty
 
-            Bytes.blit sub.bytes sub.off slice.bytes 0 len;
-            slice.off <- 0;
-            slice.len <- len;
-            Slice.consume sub len
-          )
+      method input bs i len =
+        if !remaining_size > 0 then (
+          let slice = fill_buf arg in
+          let n = min len (min slice.len !remaining_size) in
+          Bytes.blit slice.bytes slice.off bs i n;
+          remaining_size := !remaining_size - n;
+          Slice.consume slice n;
+          n
+        ) else
+          0
+
+      method consume n =
+        if n > !remaining_size then
+          invalid_arg "reading_exactly: consuming too much";
+        remaining_size := !remaining_size - n;
+        consume arg 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 (arg : t) : t =
+    reading_exactly_ ~size:max_size ~skip_on_close:false ~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 : bytes) (arg : t) : t =
-    let remaining_size = ref size in
+  let reading_exactly ~close_rec ~size (arg : t) : t =
+    reading_exactly_ ~size ~close_rec ~skip_on_close:true arg
 
-    object
-      inherit Iostream.In_buf.t_from_refill ~bytes ()
-
-      method close () =
-        if !remaining_size > 0 then skip arg !remaining_size;
-        if close_rec then close arg
-
-      method private refill slice =
-        if slice.len = 0 then
-          if !remaining_size > 0 then (
-            let sub = fill_buf arg in
-            let len = min sub.len !remaining_size in
-
-            Bytes.blit sub.bytes sub.off slice.bytes 0 len;
-            slice.off <- 0;
-            slice.len <- len;
-            Slice.consume sub len
-          )
-    end
-
-  let read_chunked ~(bytes : bytes) ~fail (bs : #t) : t =
+  let read_chunked ~(bytes : bytes) ~fail (ic : #t) : t =
     let first = ref true in
 
     (* small buffer to read the chunk sizes *)
@@ -353,11 +348,11 @@ module Input = struct
       if !first then
         first := false
       else (
-        let line = read_line_using ~buf:line_buf bs in
+        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 bs in
+      let line = read_line_using ~buf:line_buf ic in
       (* parse chunk length, ignore extensions *)
       let chunk_size =
         if String.trim line = "" then
@@ -380,7 +375,10 @@ module Input = struct
       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 && 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 (
@@ -388,12 +386,10 @@ module Input = struct
           let to_read = min !chunk_size (Bytes.length slice.bytes) in
           read_exactly_
             ~too_short:(fun () -> raise (fail "chunk is too short"))
-            bs slice.bytes to_read;
+            ic slice.bytes to_read;
           slice.len <- to_read;
           chunk_size := !chunk_size - to_read
-        ) else
-          (* stream is finished *)
-          eof := true
+        )
 
       method close () = eof := true (* do not close underlying stream *)
     end
diff --git a/src/core/request.ml b/src/core/request.ml
index df0cd1e0..c5404d85 100644
--- a/src/core/request.ml
+++ b/src/core/request.ml
@@ -71,18 +71,17 @@ 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 =
+let limit_body_size_ ~max_size (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
+  IO.Input.limit_size_to ~max_size ~close_rec:false bs
 
-let limit_body_size ~max_size ?(bytes = Bytes.create 4096) (req : IO.Input.t t)
-    : IO.Input.t t =
-  { req with body = limit_body_size_ ~max_size ~bytes req.body }
+let limit_body_size ~max_size (req : IO.Input.t t) : IO.Input.t t =
+  { req with body = limit_body_size_ ~max_size req.body }
 
 (** read exactly [size] bytes from the stream *)
-let read_exactly ~size ~bytes (bs : #IO.Input.t) : IO.Input.t =
+let read_exactly ~size (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 ~size ~bytes
+  IO.Input.reading_exactly bs ~close_rec:false ~size
 
 (* parse request, but not body (yet) *)
 let parse_req_start ~client_addr ~get_time_s ~buf (bs : IO.Input.t) :
@@ -160,18 +159,15 @@ let parse_body_ ~tr_stream ~bytes (req : IO.Input.t t) :
     in
     let body =
       match get_header ~f:String.trim req "Transfer-Encoding" with
-      | None ->
-        let bytes = Bytes.create 4096 in
-        read_exactly ~size ~bytes @@ tr_stream req.body
+      | None -> read_exactly ~size @@ tr_stream req.body
       | Some "chunked" ->
         (* body sent by chunks *)
         let bs : IO.Input.t =
           read_stream_chunked_ ~bytes @@ tr_stream req.body
         in
-        if size > 0 then (
-          let bytes = Bytes.create 4096 in
-          limit_body_size_ ~max_size:size ~bytes bs
-        ) else
+        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
diff --git a/src/core/request.mli b/src/core/request.mli
index 731cfe69..25981a66 100644
--- a/src/core/request.mli
+++ b/src/core/request.mli
@@ -107,11 +107,9 @@ 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
+val limit_body_size : max_size:int -> IO.Input.t t -> IO.Input.t t
 (** Limit the body size to [max_size] bytes, or return
       a [413] error.
-      @param bytes intermediate buffer
       @since 0.3
   *)
 
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..c3c888dc 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,9 +9,13 @@ 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 ->
@@ -19,6 +23,6 @@ let () =
     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
+    let req = Request.Private_.parse_body req str |> Request.read_body_full in
     assert_eq ~to_string:(fun s -> s) "salutations" req.Request.body;
     ()
diff --git a/tests/unit/t_util.ml b/tests/unit/t_util.ml
index 3ae913a4..7f9eac7f 100644
--- a/tests/unit/t_util.ml
+++ b/tests/unit/t_util.ml
@@ -1,33 +1,34 @@
 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 () =
   add_qcheck
@@ -43,9 +44,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 ()

From 950f0e734f84f25bb954ec07c083ba608ef0052b Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Mon, 26 Feb 2024 22:50:30 -0500
Subject: [PATCH 09/20] fix bugs

---
 src/core/IO.ml       | 49 ++++++++++++++++++++------------------------
 src/core/request.ml  | 30 +++++++++++++++------------
 src/core/request.mli |  3 ++-
 src/unix/dir.ml      |  5 +++--
 4 files changed, 44 insertions(+), 43 deletions(-)

diff --git a/src/core/IO.ml b/src/core/IO.ml
index 525b0472..249da955 100644
--- a/src/core/IO.ml
+++ b/src/core/IO.ml
@@ -235,7 +235,7 @@ module Input = struct
     Buf.clear buf;
     let continue = ref true in
     while !continue do
-      let slice = self#fill_buf () in
+      let slice = fill_buf self in
       if slice.len = 0 then
         continue := false
       else (
@@ -246,7 +246,7 @@ module Input = struct
     done;
     Buf.contents_and_clear buf
 
-  (** put [n] bytes from the input into bytes *)
+  (** 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
@@ -295,49 +295,44 @@ module Input = struct
     | () -> Some (Buf.contents_and_clear buf)
     | exception End_of_file -> None
 
-  let reading_exactly_ ~skip_on_close ~close_rec ~size (arg : t) : t =
+  (* 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 fill_buf () =
-        if !remaining_size > 0 then
-          fill_buf arg
-        else
-          Slice.empty
-
-      method input bs i len =
+      method private refill (slice : Slice.t) =
+        slice.off <- 0;
+        slice.len <- 0;
         if !remaining_size > 0 then (
-          let slice = fill_buf arg in
-          let n = min len (min slice.len !remaining_size) in
-          Bytes.blit slice.bytes slice.off bs i n;
+          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.consume slice n;
-          n
-        ) else
-          0
-
-      method consume n =
-        if n > !remaining_size then
-          invalid_arg "reading_exactly: consuming too much";
-        remaining_size := !remaining_size - n;
-        consume arg 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 (arg : t) : t =
-    reading_exactly_ ~size:max_size ~skip_on_close:false ~close_rec arg
+  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 (arg : t) : t =
-    reading_exactly_ ~size ~close_rec ~skip_on_close:true arg
+  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
diff --git a/src/core/request.ml b/src/core/request.ml
index c5404d85..de982367 100644
--- a/src/core/request.ml
+++ b/src/core/request.ml
@@ -71,17 +71,17 @@ 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 (bs : #IO.Input.t) : IO.Input.t =
+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 bs
+  IO.Input.limit_size_to ~max_size ~close_rec:false ~bytes bs
 
-let limit_body_size ~max_size (req : IO.Input.t t) : IO.Input.t t =
-  { req with body = limit_body_size_ ~max_size req.body }
+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 (bs : #IO.Input.t) : IO.Input.t =
+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 ~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) :
@@ -151,23 +151,27 @@ let parse_req_start ~client_addr ~get_time_s ~buf (bs : IO.Input.t) :
 let parse_body_ ~tr_stream ~bytes (req : IO.Input.t t) :
     IO.Input.t t resp_result =
   try
-    let size =
+    let size, has_size =
       match Headers.get_exn "Content-Length" req.headers |> int_of_string with
-      | n -> n (* body of fixed size *)
-      | exception Not_found -> 0
+      | 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 @@ tr_stream req.body
+      | 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
-          limit_body_size_ ~max_size:size bs
-        else
+        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
diff --git a/src/core/request.mli b/src/core/request.mli
index 25981a66..70ae741d 100644
--- a/src/core/request.mli
+++ b/src/core/request.mli
@@ -107,7 +107,8 @@ 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 -> IO.Input.t t -> IO.Input.t t
+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
diff --git a/src/unix/dir.ml b/src/unix/dir.ml
index d596a78f..f29e9db5 100644
--- a/src/unix/dir.ml
+++ b/src/unix/dir.ml
@@ -253,9 +253,10 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
               (Printexc.to_string e)
         in
         let req =
-          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
-        IO.Input.iter write req.Request.body;
+        IO.Input.iter write req.body;
         close ();
         Log.debug (fun k -> k "dir: done uploading file to %S" path);
         Response.make_raw ~code:201 "upload successful")

From 6cfd1975d1fdaf0ed05d84d8533504ed1f17852e Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Mon, 26 Feb 2024 22:54:45 -0500
Subject: [PATCH 10/20] details for logs

---
 tests/unit/t_server.ml       | 10 +++++-----
 tests/unit/util/dune         |  2 +-
 tests/unit/util/test_util.ml |  4 ++++
 3 files changed, 10 insertions(+), 6 deletions(-)

diff --git a/tests/unit/t_server.ml b/tests/unit/t_server.ml
index c3c888dc..01b82eac 100644
--- a/tests/unit/t_server.ml
+++ b/tests/unit/t_server.ml
@@ -19,10 +19,10 @@ let () =
   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;
+    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.Request.body;
+    assert_eq ~to_string:(fun s -> s) "salutations" req.body;
     ()
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

From 384515a594f0a0e0351245470f3c9abc50bf1b00 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Tue, 27 Feb 2024 11:00:42 -0500
Subject: [PATCH 11/20] dir: handle html

---
 src/unix/dir.ml | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/unix/dir.ml b/src/unix/dir.ml
index f29e9db5..0035849c 100644
--- a/src/unix/dir.ml
+++ b/src/unix/dir.ml
@@ -310,7 +310,10 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
         ) 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" ]

From 1debf0f688ae61b4b3a5f687f0c8e3f5dc7f64db Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Tue, 27 Feb 2024 13:38:35 -0500
Subject: [PATCH 12/20] expose all modules again

---
 src/Tiny_httpd.ml  | 16 ++++++++++------
 src/Tiny_httpd.mli | 14 +++++++-------
 2 files changed, 17 insertions(+), 13 deletions(-)

diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml
index 85c7c3fe..cbffe69b 100644
--- a/src/Tiny_httpd.ml
+++ b/src/Tiny_httpd.ml
@@ -1,16 +1,20 @@
 module Buf = Buf
-include Server
-module Util = Util
-module Dir = Tiny_httpd_unix.Dir
-
-module type VFS = Tiny_httpd_unix.Dir.VFS
-
 module Html = Tiny_httpd_html
 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 =
diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli
index 584d0188..2490646e 100644
--- a/src/Tiny_httpd.mli
+++ b/src/Tiny_httpd.mli
@@ -89,13 +89,6 @@ module IO = Tiny_httpd_core.IO
 
 module Log = Tiny_httpd_core.Log
 
-(** {2 Main Server Type} *)
-
-(** @inline *)
-include module type of struct
-  include Tiny_httpd_core.Server
-end
-
 (** {2 Utils} *)
 
 module Util = Tiny_httpd_core.Util
@@ -118,8 +111,15 @@ module Html = Tiny_httpd_html
 
 (** {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

From bcc208cf59eeabac9784dc8afd55b9603e9b49e7 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Tue, 27 Feb 2024 15:14:12 -0500
Subject: [PATCH 13/20] fix middlewares: merge-sort per-request middleares and
 global ones

---
 src/core/server.ml | 33 +++++++++++++++++++++------------
 1 file changed, 21 insertions(+), 12 deletions(-)

diff --git a/src/core/server.ml b/src/core/server.ml
index e24bed89..764c1eae 100644
--- a/src/core/server.ml
+++ b/src/core/server.ml
@@ -60,12 +60,12 @@ module type IO_BACKEND = sig
 end
 
 type handler_result =
-  | Handle of cb_path_handler
+  | Handle of (int * Middleware.t) list * cb_path_handler
   | Fail of resp_error
   | Upgrade of upgrade_handler
 
 let unwrap_handler_result req = function
-  | Handle x -> x
+  | Handle (l, h) -> l, h
   | Fail (c, s) -> raise (Bad_req (c, s))
   | Upgrade up -> raise (Upgrade (req, up))
 
@@ -101,6 +101,9 @@ let active_connections (self : t) =
   | 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
@@ -109,9 +112,7 @@ let add_middleware ~stage self m =
     | `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)
+  self.middlewares_sorted <- lazy (sort_middlewares_ self.middlewares)
 
 let add_decode_request_cb self f =
   (* turn it into a middleware *)
@@ -145,6 +146,7 @@ let set_top_handler self f = self.handler <- f
    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 *)
@@ -156,9 +158,7 @@ let add_route_handler_ ?(accept = fun _req -> Ok ()) ?(middlewares = []) ?meth
         | Ok () ->
           Some
             (Handle
-               (fun oc ->
-                 Middleware.apply_l middlewares @@ fun req ~resp ->
-                 tr_req oc req ~resp handler))
+               (middlewares, fun oc req ~resp -> tr_req oc req ~resp handler))
         | Error err -> Some (Fail err))
       | None -> None (* path didn't match *))
   in
@@ -409,10 +409,10 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
 
       (try
          (* is there a handler for this path? *)
-         let base_handler =
+         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)
+           | None -> [], fun _oc req ~resp -> resp (self.handler req)
          in
 
          (* handle expect/continue *)
@@ -424,12 +424,21 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
          | 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)
-             (Lazy.force self.middlewares_sorted)
-             (base_handler oc)
+             all_middlewares (base_handler oc)
          in
 
          (* now actually read request's body into a stream *)

From 179d41cd9a2c99cf4f07bbf395be3354f55bc28e Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Wed, 28 Feb 2024 09:46:34 -0500
Subject: [PATCH 14/20] logging

---
 src/core/server.ml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/core/server.ml b/src/core/server.ml
index 764c1eae..1eb1715b 100644
--- a/src/core/server.ml
+++ b/src/core/server.ml
@@ -312,9 +312,9 @@ let client_handle_for (self : t) ~client_addr ic oc : unit =
       let msgf k =
         let elapsed = B.get_time_s () -. req.start_time in
         k
-          ("response to=%s code=%d time=%.3fs path=%S" : _ format4)
+          ("response to=%s code=%d time=%.3fs meth=%s path=%S" : _ format4)
           (Util.show_sockaddr client_addr)
-          resp.code elapsed req.path
+          resp.code elapsed (Meth.to_string req.meth) req.path
       in
       if Response_code.is_success resp.code then
         Log.info msgf

From 7e790c016125cfae73120ce2c719afc70a4b663c Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Wed, 28 Feb 2024 15:01:13 -0500
Subject: [PATCH 15/20] fix: parse query when there's a fragment indication

---
 src/core/util.ml     | 5 +++++
 tests/unit/t_util.ml | 2 ++
 2 files changed, 7 insertions(+)

diff --git a/src/core/util.ml b/src/core/util.ml
index 8a2b861d..78845fa9 100644
--- a/src/core/util.ml
+++ b/src/core/util.ml
@@ -76,6 +76,11 @@ let split_on_slash s : _ list =
   List.rev !l
 
 let parse_query s : (_ list, string) result =
+  let s =
+    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
diff --git a/tests/unit/t_util.ml b/tests/unit/t_util.ml
index 7f9eac7f..db3c6758 100644
--- a/tests/unit/t_util.ml
+++ b/tests/unit/t_util.ml
@@ -30,6 +30,8 @@ let () = assert_eq [] (U.split_on_slash "//")
 let () =
   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
   @@ QCheck.Test.make ~long_factor:20 ~count:1_000

From 91951ca5a1202ff96ad8464486c3fba53ff17941 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Wed, 28 Feb 2024 15:05:23 -0500
Subject: [PATCH 16/20] logging

---
 src/core/request.ml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/core/request.ml b/src/core/request.ml
index de982367..b8573052 100644
--- a/src/core/request.ml
+++ b/src/core/request.ml
@@ -88,6 +88,7 @@ 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

From 5a38ffdce757f6ca1562bb35f9b94324ed995532 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Wed, 28 Feb 2024 15:16:14 -0500
Subject: [PATCH 17/20] comment

---
 src/core/util.ml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/core/util.ml b/src/core/util.ml
index 78845fa9..38d9bbb9 100644
--- a/src/core/util.ml
+++ b/src/core/util.ml
@@ -77,6 +77,7 @@ let split_on_slash s : _ list =
 
 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

From 7de89bd55502c876e06582f95a84e6cd4566e5e1 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Wed, 28 Feb 2024 16:11:16 -0500
Subject: [PATCH 18/20] expose Response.Bad_req

---
 src/core/response.ml  | 2 ++
 src/core/response.mli | 8 ++++++--
 2 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/src/core/response.ml b/src/core/response.ml
index 3e2d4347..e1d2721a 100644
--- a/src/core/response.ml
+++ b/src/core/response.ml
@@ -63,6 +63,8 @@ let make ?headers ?(code = 200) r : t =
 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
 
diff --git a/src/core/response.mli b/src/core/response.mli
index 6ddf08b8..4cf0f192 100644
--- a/src/core/response.mli
+++ b/src/core/response.mli
@@ -99,10 +99,14 @@ val fail : ?headers:Headers.t -> code:int -> ('a, unit, string, t) format4 -> 'a
       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()]
+    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

From eada4cde08208dd4e38e8fad1586f42565c7f502 Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Wed, 28 Feb 2024 16:24:15 -0500
Subject: [PATCH 19/20] less verbose logs for unix server

---
 src/unix/tiny_httpd_unix.ml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/unix/tiny_httpd_unix.ml b/src/unix/tiny_httpd_unix.ml
index 37f5f921..f1de3936 100644
--- a/src/unix/tiny_httpd_unix.ml
+++ b/src/unix/tiny_httpd_unix.ml
@@ -78,7 +78,7 @@ module Unix_tcp_server_ = struct
           (* how to handle a single client *)
           let handle_client_unix_ (client_sock : Unix.file_descr)
               (client_addr : Unix.sockaddr) : unit =
-            Log.info (fun k ->
+            Log.debug (fun k ->
                 k "t[%d]: serving new client on %s"
                   (Thread.id @@ Thread.self ())
                   (Util.show_sockaddr client_addr));
@@ -117,7 +117,7 @@ module Unix_tcp_server_ = struct
               self.new_thread (fun () ->
                   try
                     handle_client_unix_ client_sock client_addr;
-                    Log.info (fun k ->
+                    Log.debug (fun k ->
                         k "t[%d]: done with client on %s, exiting"
                           (Thread.id @@ Thread.self ())
                         @@ Util.show_sockaddr client_addr);

From 05dcf779817ac5449b9688903e23f5dec0704b5c Mon Sep 17 00:00:00 2001
From: Simon Cruanes 
Date: Thu, 29 Feb 2024 10:23:38 -0500
Subject: [PATCH 20/20] feat: add `Request.pp_with` which is a customizable
 printer

---
 src/core/request.ml  | 39 ++++++++++++++++++++++++++++++---------
 src/core/request.mli | 21 +++++++++++++++++++++
 2 files changed, 51 insertions(+), 9 deletions(-)

diff --git a/src/core/request.ml b/src/core/request.ml
index b8573052..1a3275df 100644
--- a/src/core/request.ml
+++ b/src/core/request.ml
@@ -52,19 +52,40 @@ 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 =
+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=?;@ \
+    "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ body=%a;@ \
      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
+    (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 =
-  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
+  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 =
diff --git a/src/core/request.mli b/src/core/request.mli
index 70ae741d..e4242bcf 100644
--- a/src/core/request.mli
+++ b/src/core/request.mli
@@ -49,6 +49,27 @@ val get_meta_exn : _ t -> 'a Hmap.key -> 'a
     @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. *)