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