Merge pull request #81 from c-cube/refactor-and-use-hmap

Refactor, modularize, add hmap to requests

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "vendor/iostream"]
+	path = vendor/iostream
+	url = https://github.com/c-cube/ocaml-iostream

dune-project

@@ -21,6 +21,8 @@
     seq
     base-threads
     result
+    hmap
+    (iostream (>= 0.2))
     (ocaml (>= 4.08))
     (odoc :with-doc)
     (logs :with-test)
@@ -34,5 +36,6 @@
   (depends
     (tiny_httpd (= :version))
     (camlzip (>= 1.06))
+    iostream-camlzip
     (logs :with-test)
     (odoc :with-doc)))

examples/echo.ml

@@ -1,4 +1,4 @@
-module S = Tiny_httpd
+open Tiny_httpd_core
 module Log = Tiny_httpd.Log
 
 let now_ = Unix.gettimeofday
@@ -34,7 +34,7 @@ let alice_text =
    sides of the well, and noticed that they were filled with cupboards......"
 
 (* util: a little middleware collecting statistics *)
-let middleware_stat () : S.Middleware.t * (unit -> string) =
+let middleware_stat () : Server.Middleware.t * (unit -> string) =
   let n_req = ref 0 in
   let total_time_ = ref 0. in
   let parse_time_ = ref 0. in
@@ -43,7 +43,7 @@ let middleware_stat () : S.Middleware.t * (unit -> string) =
 
   let m h req ~resp =
     incr n_req;
-    let t1 = S.Request.start_time req in
+    let t1 = Request.start_time req in
     let t2 = now_ () in
     h req ~resp:(fun response ->
         let t3 = now_ () in
@@ -92,23 +92,23 @@ let () =
     (fun _ -> raise (Arg.Bad ""))
     "echo [option]*";
 
-  let server = S.create ~port:!port_ ~max_connections:!j () in
+  let server = Tiny_httpd.create ~port:!port_ ~max_connections:!j () in
 
   Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16 * 1024) server;
   let m_stats, get_stats = middleware_stat () in
-  S.add_middleware server ~stage:(`Stage 1) m_stats;
+  Server.add_middleware server ~stage:(`Stage 1) m_stats;
 
   (* say hello *)
-  S.add_route_handler ~meth:`GET server
+  Server.add_route_handler ~meth:`GET server
-    S.Route.(exact "hello" @/ string @/ return)
+    Route.(exact "hello" @/ string @/ return)
-    (fun name _req -> S.Response.make_string (Ok ("hello " ^ name ^ "!\n")));
+    (fun name _req -> Response.make_string (Ok ("hello " ^ name ^ "!\n")));
 
   (* compressed file access *)
-  S.add_route_handler ~meth:`GET server
+  Server.add_route_handler ~meth:`GET server
-    S.Route.(exact "zcat" @/ string_urlencoded @/ return)
+    Route.(exact "zcat" @/ string_urlencoded @/ return)
     (fun path _req ->
       let ic = open_in path in
-      let str = S.Byte_stream.of_chan ic in
+      let str = IO.Input.of_in_channel ic in
       let mime_type =
         try
           let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" path) in
@@ -121,42 +121,42 @@ let () =
             []
         with _ -> []
       in
-      S.Response.make_stream ~headers:mime_type (Ok str));
+      Response.make_stream ~headers:mime_type (Ok str));
 
   (* echo request *)
-  S.add_route_handler server
+  Server.add_route_handler server
-    S.Route.(exact "echo" @/ return)
+    Route.(exact "echo" @/ return)
     (fun req ->
       let q =
-        S.Request.query req
+        Request.query req
         |> List.map (fun (k, v) -> Printf.sprintf "%S = %S" k v)
         |> String.concat ";"
       in
-      S.Response.make_string
+      Response.make_string
-        (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." S.Request.pp req q)));
+        (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." Request.pp req q)));
 
   (* file upload *)
-  S.add_route_handler_stream ~meth:`PUT server
+  Server.add_route_handler_stream ~meth:`PUT server
-    S.Route.(exact "upload" @/ string @/ return)
+    Route.(exact "upload" @/ string @/ return)
     (fun path req ->
       Log.debug (fun k ->
           k "start upload %S, headers:\n%s\n\n%!" path
-            (Format.asprintf "%a" S.Headers.pp (S.Request.headers req)));
+            (Format.asprintf "%a" Headers.pp (Request.headers req)));
       try
         let oc = open_out @@ "/tmp/" ^ path in
-        S.Byte_stream.to_chan oc req.S.Request.body;
+        IO.Input.to_chan oc req.Request.body;
         flush oc;
-        S.Response.make_string (Ok "uploaded file")
+        Response.make_string (Ok "uploaded file")
       with e ->
-        S.Response.fail ~code:500 "couldn't upload file: %s"
+        Response.fail ~code:500 "couldn't upload file: %s"
           (Printexc.to_string e));
 
   (* protected by login *)
-  S.add_route_handler server
+  Server.add_route_handler server
-    S.Route.(exact "protected" @/ return)
+    Route.(exact "protected" @/ return)
     (fun req ->
       let ok =
-        match S.Request.get_header req "authorization" with
+        match Request.get_header req "authorization" with
         | Some v ->
           Log.debug (fun k -> k "authenticate with %S" v);
           v = "Basic " ^ base64 "user:foobar"
@@ -167,40 +167,40 @@ let () =
         let s =
           "<p>hello, this is super secret!</p><a href=\"/logout\">log out</a>"
         in
-        S.Response.make_string (Ok s)
+        Response.make_string (Ok s)
       ) else (
         let headers =
-          S.Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"")
+          Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"")
         in
-        S.Response.fail ~code:401 ~headers "invalid"
+        Response.fail ~code:401 ~headers "invalid"
       ));
 
   (* logout *)
-  S.add_route_handler server
+  Server.add_route_handler server
-    S.Route.(exact "logout" @/ return)
+    Route.(exact "logout" @/ return)
-    (fun _req -> S.Response.fail ~code:401 "logged out");
+    (fun _req -> Response.fail ~code:401 "logged out");
 
   (* stats *)
-  S.add_route_handler server
+  Server.add_route_handler server
-    S.Route.(exact "stats" @/ return)
+    Route.(exact "stats" @/ return)
     (fun _req ->
       let stats = get_stats () in
-      S.Response.make_string @@ Ok stats);
+      Response.make_string @@ Ok stats);
 
-  S.add_route_handler server
+  Server.add_route_handler server
-    S.Route.(exact "alice" @/ return)
+    Route.(exact "alice" @/ return)
-    (fun _req -> S.Response.make_string (Ok alice_text));
+    (fun _req -> Response.make_string (Ok alice_text));
 
   (* VFS *)
-  Tiny_httpd_dir.add_vfs server
+  Tiny_httpd.Dir.add_vfs server
     ~config:
-      (Tiny_httpd_dir.config ~download:true
+      (Tiny_httpd.Dir.config ~download:true
-         ~dir_behavior:Tiny_httpd_dir.Index_or_lists ())
+         ~dir_behavior:Tiny_httpd.Dir.Index_or_lists ())
     ~vfs:Vfs.vfs ~prefix:"vfs";
 
   (* main page *)
-  S.add_route_handler server
+  Server.add_route_handler server
-    S.Route.(return)
+    Route.(return)
     (fun _req ->
       let open Tiny_httpd_html in
       let h =
@@ -272,9 +272,10 @@ let () =
           ]
       in
       let s = to_string_top h in
-      S.Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok s);
+      Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok s);
 
-  Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
+  Printf.printf "listening on http://%s:%d\n%!" (Server.addr server)
-  match S.run server with
+    (Server.port server);
+  match Server.run server with
   | Ok () -> ()
   | Error e -> raise e

examples/echo_ws.ml

@@ -1,6 +1,5 @@
 module S = Tiny_httpd
-module Log = Tiny_httpd.Log
+open Tiny_httpd_core
-module IO = Tiny_httpd_io
 
 let setup_logging ~debug () =
   Logs.set_reporter @@ Logs.format_reporter ();
@@ -13,8 +12,7 @@ let setup_logging ~debug () =
 
 let handle_ws _client_addr ic oc =
   Log.info (fun k ->
-      k "new client connection from %s"
+      k "new client connection from %s" (Util.show_sockaddr _client_addr));
-        (Tiny_httpd_util.show_sockaddr _client_addr));
 
   let (_ : Thread.t) =
     Thread.create
@@ -58,7 +56,7 @@ let () =
 
   let server = S.create ~port:!port_ ~max_connections:!j () in
   Tiny_httpd_ws.add_route_handler server
-    S.Route.(exact "echo" @/ return)
+    Route.(exact "echo" @/ return)
     handle_ws;
 
   Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);

examples/sse_server.ml

@@ -1,7 +1,6 @@
 (* serves some streams of events *)
 
-module S = Tiny_httpd
+open Tiny_httpd_core
-module Log = Tiny_httpd_log
 
 let port = ref 8080
 
@@ -14,7 +13,7 @@ let () =
        ])
     (fun _ -> ())
     "sse_clock [opt*]";
-  let server = S.create ~port:!port () in
+  let server = Tiny_httpd.create ~port:!port () in
 
   let extra_headers =
     [
@@ -24,9 +23,9 @@ let () =
   in
 
   (* tick/tock goes the clock *)
-  S.add_route_server_sent_handler server
+  Server.add_route_server_sent_handler server
-    S.Route.(exact "clock" @/ return)
+    Route.(exact "clock" @/ return)
-    (fun _req (module EV : S.SERVER_SENT_GENERATOR) ->
+    (fun _req (module EV : Server.SERVER_SENT_GENERATOR) ->
       Log.debug (fun k -> k "new SSE connection");
       EV.set_headers extra_headers;
       let tick = ref true in
@@ -47,26 +46,26 @@ let () =
       done);
 
   (* just count *)
-  S.add_route_server_sent_handler server
+  Server.add_route_server_sent_handler server
-    S.Route.(exact "count" @/ return)
+    Route.(exact "count" @/ return)
-    (fun _req (module EV : S.SERVER_SENT_GENERATOR) ->
+    (fun _req (module EV : Server.SERVER_SENT_GENERATOR) ->
       let n = ref 0 in
       while true do
         EV.send_event ~data:(string_of_int !n) ();
         incr n;
         Unix.sleepf 0.1
       done);
-  S.add_route_server_sent_handler server
+  Server.add_route_server_sent_handler server
-    S.Route.(exact "count" @/ int @/ return)
+    Route.(exact "count" @/ int @/ return)
-    (fun n _req (module EV : S.SERVER_SENT_GENERATOR) ->
+    (fun n _req (module EV : Server.SERVER_SENT_GENERATOR) ->
       for i = 0 to n do
         EV.send_event ~data:(string_of_int i) ();
         Unix.sleepf 0.1
       done;
       EV.close ());
 
-  Printf.printf "listening on http://localhost:%d/\n%!" (S.port server);
+  Printf.printf "listening on http://localhost:%d/\n%!" (Server.port server);
-  match S.run server with
+  match Server.run server with
   | Ok () -> ()
   | Error e ->
     Printf.eprintf "error: %s\n%!" (Printexc.to_string e);

examples/writer.ml

@@ -1,7 +1,8 @@
 module H = Tiny_httpd
+open Tiny_httpd_core
 
 let serve_zeroes server : unit =
-  H.add_route_handler server H.(Route.(exact "zeroes" @/ int @/ return))
+  Server.add_route_handler server Route.(exact "zeroes" @/ int @/ return)
   @@ fun n _req ->
   (* stream [n] zeroes *)
   let write (oc : H.IO.Output.t) : unit =
@@ -11,7 +12,7 @@ let serve_zeroes server : unit =
     done
   in
   let writer = H.IO.Writer.make ~write () in
-  H.Response.make_writer @@ Ok writer
+  Response.make_writer @@ Ok writer
 
 let serve_file server : unit =
   H.add_route_handler server H.(Route.(exact "file" @/ string @/ return))
@@ -32,9 +33,9 @@ let serve_file server : unit =
     in
 
     let writer = H.IO.Writer.make ~write () in
-    H.Response.make_writer @@ Ok writer
+    Response.make_writer @@ Ok writer
   ) else
-    H.Response.fail ~code:404 "file not found"
+    Response.fail ~code:404 "file not found"
 
 let () =
   let port = ref 8085 in
@@ -43,7 +44,7 @@ let () =
   Printf.printf "listen on http://localhost:%d/\n%!" !port;
   serve_file server;
   serve_zeroes server;
-  H.add_route_handler server H.Route.return (fun _req ->
+  H.add_route_handler server Route.return (fun _req ->
       let body =
         H.Html.(
           div []
@@ -58,5 +59,5 @@ let () =
             ])
         |> H.Html.to_string_top
       in
-      H.Response.make_string @@ Ok body);
+      Response.make_string @@ Ok body);
   H.run_exn server

src/Tiny_httpd.ml

@@ -1,9 +1,68 @@
-module Buf = Tiny_httpd_buf
+module Buf = Buf
-module Byte_stream = Tiny_httpd_stream
-include Tiny_httpd_server
-module Util = Tiny_httpd_util
-module Dir = Tiny_httpd_dir
 module Html = Tiny_httpd_html
-module IO = Tiny_httpd_io
+module IO = Tiny_httpd_core.IO
-module Pool = Tiny_httpd_pool
+module Request = Tiny_httpd_core.Request
-module Log = Tiny_httpd_log
+module Response = Tiny_httpd_core.Response
+module Response_code = Tiny_httpd_core.Response_code
+module Route = Tiny_httpd_core.Route
+module Headers = Tiny_httpd_core.Headers
+module Meth = Tiny_httpd_core.Meth
+module Pool = Tiny_httpd_core.Pool
+module Log = Tiny_httpd_core.Log
+module Server = Tiny_httpd_core.Server
+module Util = Tiny_httpd_core.Util
+include Server
+module Dir = Tiny_httpd_unix.Dir
+
+module type VFS = Tiny_httpd_unix.Dir.VFS
+
+open struct
+  let get_max_connection_ ?(max_connections = 64) () : int =
+    let max_connections = max 4 max_connections in
+    max_connections
+
+  let clear_slice (slice : IO.Slice.t) =
+    Bytes.fill slice.bytes 0 (Bytes.length slice.bytes) '\x00';
+    slice.off <- 0;
+    slice.len <- 0
+end
+
+let create ?(masksigpipe = true) ?max_connections ?(timeout = 0.0) ?buf_size
+    ?(get_time_s = Unix.gettimeofday)
+    ?(new_thread = fun f -> ignore (Thread.create f () : Thread.t))
+    ?(addr = "127.0.0.1") ?(port = 8080) ?sock ?middlewares () : t =
+  let max_connections = get_max_connection_ ?max_connections () in
+  let server =
+    {
+      Tiny_httpd_unix.Unix_tcp_server_.addr;
+      new_thread;
+      buf_pool =
+        Pool.create ~clear:Buf.clear_and_zero
+          ~mk_item:(fun () -> Buf.create ?size:buf_size ())
+          ();
+      slice_pool =
+        Pool.create ~clear:clear_slice
+          ~mk_item:
+            (let buf_size = Option.value buf_size ~default:4096 in
+             fun () -> IO.Slice.create buf_size)
+          ();
+      running = true;
+      port;
+      sock;
+      max_connections;
+      sem_max_connections = Tiny_httpd_unix.Sem.create max_connections;
+      masksigpipe;
+      timeout;
+    }
+  in
+  let tcp_server_builder =
+    Tiny_httpd_unix.Unix_tcp_server_.to_tcp_server server
+  in
+  let module B = struct
+    let init_addr () = addr
+    let init_port () = port
+    let get_time_s = get_time_s
+    let tcp_server () = tcp_server_builder
+  end in
+  let backend = (module B : IO_BACKEND) in
+  Server.create_from ?buf_size ?middlewares ~backend ()

src/Tiny_httpd.mli

@@ -79,39 +79,94 @@ echo:
     processing streams and parsing requests.
 *)
 
-module Buf = Tiny_httpd_buf
+module Buf = Buf
-
-(** {2 Generic byte streams} *)
-
-module Byte_stream = Tiny_httpd_stream
 
 (** {2 IO Abstraction} *)
 
-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
-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 type VFS = Tiny_httpd_unix.Dir.VFS
+
+(** {2 HTML combinators} *)
 
 module Html = Tiny_httpd_html
 (** Alias to {!Tiny_httpd_html}
     @since 0.12 *)
+
+(** {2 Main server types} *)
+
+module Request = Tiny_httpd_core.Request
+module Response = Tiny_httpd_core.Response
+module Response_code = Tiny_httpd_core.Response_code
+module Route = Tiny_httpd_core.Route
+module Headers = Tiny_httpd_core.Headers
+module Meth = Tiny_httpd_core.Meth
+module Server = Tiny_httpd_core.Server
+
+(** @inline *)
+include module type of struct
+  include Server
+end
+
+val create :
+  ?masksigpipe:bool ->
+  ?max_connections:int ->
+  ?timeout:float ->
+  ?buf_size:int ->
+  ?get_time_s:(unit -> float) ->
+  ?new_thread:((unit -> unit) -> unit) ->
+  ?addr:string ->
+  ?port:int ->
+  ?sock:Unix.file_descr ->
+  ?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
+  unit ->
+  t
+(** Create a new webserver using UNIX abstractions.
+
+    The server will not do anything until {!run} is called on it.
+    Before starting the server, one can use {!add_path_handler} and
+    {!set_top_handler} to specify how to handle incoming requests.
+
+    @param masksigpipe if true, block the signal {!Sys.sigpipe} which otherwise
+    tends to kill client threads when they try to write on broken sockets. Default: [true].
+
+    @param buf_size size for buffers (since 0.11)
+
+    @param new_thread a function used to spawn a new thread to handle a
+    new client connection. By default it is {!Thread.create} but one
+    could use a thread pool instead.
+    See for example {{: https://github.com/c-cube/tiny-httpd-moonpool-bench/blob/0dcbbffb4fe34ea4ad79d46343ad0cebb69ca69f/examples/t1.ml#L31}
+      this use of moonpool}.
+
+    @param middlewares see {!add_middleware} for more details.
+
+    @param max_connections maximum number of simultaneous connections.
+    @param timeout connection is closed if the socket does not do read or
+      write for the amount of second. Default: 0.0 which means no timeout.
+      timeout is not recommended when using proxy.
+    @param addr address (IPv4 or IPv6) to listen on. Default ["127.0.0.1"].
+    @param port to listen on. Default [8080].
+    @param sock an existing socket given to the server to listen on, e.g. by
+      systemd on Linux (or launchd on macOS). If passed in, this socket will be
+      used instead of the [addr] and [port]. If not passed in, those will be
+      used. This parameter exists since 0.10.
+
+    @param get_time_s obtain the current timestamp in seconds.
+      This parameter exists since 0.11.
+*)

src/Tiny_httpd_io.ml

@@ -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

src/Tiny_httpd_server.mli

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

src/bin/http_of_dir.ml

@@ -1,6 +1,6 @@
 module S = Tiny_httpd
-module U = Tiny_httpd_util
+module U = Tiny_httpd.Util
-module D = Tiny_httpd_dir
+module D = Tiny_httpd.Dir
 module Pf = Printf
 module Log = Tiny_httpd.Log
 

src/bin/vfs_pack.ml

@@ -33,12 +33,12 @@ let is_url s =
   is_prefix "http://" s || is_prefix "https://" s
 
 let emit oc (l : entry list) : unit =
-  fpf oc "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:%f ()\n"
+  fpf oc "let embedded_fs = Tiny_httpd.Dir.Embedded_fs.create ~mtime:%f ()\n"
     now_;
 
   let add_vfs ~mtime vfs_path content =
     fpf oc
-      "let () = Tiny_httpd_dir.Embedded_fs.add_file embedded_fs \n\
+      "let () = Tiny_httpd.Dir.Embedded_fs.add_file embedded_fs \n\
       \  ~mtime:%h ~path:%S\n\
       \  %S\n"
       mtime vfs_path content
@@ -99,7 +99,7 @@ let emit oc (l : entry list) : unit =
   in
   List.iter add_entry l;
 
-  fpf oc "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs\n";
+  fpf oc "let vfs = Tiny_httpd.Dir.Embedded_fs.to_vfs embedded_fs\n";
   ()
 
 let help =

src/camlzip/Tiny_httpd_camlzip.ml

@@ -1,175 +1,59 @@
-module S = Tiny_httpd_server
+module W = IO.Writer
-module BS = Tiny_httpd_stream
-module W = Tiny_httpd_io.Writer
-module Out = Tiny_httpd_io.Output
-module Log = Tiny_httpd.Log
 
-let decode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream =
+(* TODO: just use iostream-camlzip? *)
+
+let decode_deflate_stream_ ~buf_size (ic : IO.Input.t) : IO.Input.t =
   Log.debug (fun k -> k "wrap stream with deflate.decode");
-  let zlib_str = Zlib.inflate_init false in
+  Iostream_camlzip.decompress_in_buf ~buf_size ic
-  let is_done = ref false in
-  BS.make ~bs:(Bytes.create buf_size)
-    ~close:(fun _ ->
-      Zlib.inflate_end zlib_str;
-      BS.close is)
-    ~consume:(fun self len ->
-      if len > self.len then
-        S.Response.fail_raise ~code:400
-          "inflate: error during decompression: invalid consume len %d (max %d)"
-          len self.len;
-      self.off <- self.off + len;
-      self.len <- self.len - len)
-    ~fill:(fun self ->
-      (* refill [buf] if needed *)
-      if self.len = 0 && not !is_done then (
-        is.fill_buf ();
-        (try
-           let finished, used_in, used_out =
-             Zlib.inflate zlib_str self.bs 0 (Bytes.length self.bs) is.bs is.off
-               is.len Zlib.Z_SYNC_FLUSH
-           in
-           is.consume used_in;
-           self.off <- 0;
-           self.len <- used_out;
-           if finished then is_done := true;
-           Log.debug (fun k ->
-               k "decode %d bytes as %d bytes from inflate (finished: %b)"
-                 used_in used_out finished)
-         with Zlib.Error (e1, e2) ->
-           S.Response.fail_raise ~code:400
-             "inflate: error during decompression:\n%s %s" e1 e2);
-        Log.debug (fun k ->
-            k "inflate: refill %d bytes into internal buf" self.len)
-      ))
-    ()
 
 let encode_deflate_writer_ ~buf_size (w : W.t) : W.t =
   Log.debug (fun k -> k "wrap writer with deflate.encode");
-  let zlib_str = Zlib.deflate_init 4 false in
 
-  let o_buf = Bytes.create buf_size in
+  let { IO.Writer.write } = w in
-  let o_off = ref 0 in
+  let write' (oc : IO.Output.t) =
-  let o_len = ref 0 in
+    let oc' = Iostream_camlzip.compressed_out ~buf_size ~level:4 oc in
-
+    write (oc' :> IO.Output.t)
-  (* write output buffer to out *)
-  let write_out (oc : Out.t) =
-    if !o_len > 0 then (
-      Out.output oc o_buf !o_off !o_len;
-      o_off := 0;
-      o_len := 0
-    )
   in
+  IO.Writer.make ~write:write' ()
 
-  let flush_zlib ~flush (oc : Out.t) =
+let accept_deflate (req : _ Request.t) =
-    let continue = ref true in
+  match Request.get_header req "Accept-Encoding" with
-    while !continue do
+  | Some s ->
-      let finished, used_in, used_out =
+    List.mem "deflate" @@ List.rev_map String.trim @@ String.split_on_char ',' s
-        Zlib.deflate zlib_str Bytes.empty 0 0 o_buf 0 (Bytes.length o_buf) flush
-      in
-      assert (used_in = 0);
-      o_len := !o_len + used_out;
-      if finished then continue := false;
-      write_out oc
-    done
-  in
-
-  (* compress and consume input buffer *)
-  let write_zlib ~flush (oc : Out.t) buf i len =
-    let i = ref i in
-    let len = ref len in
-    while !len > 0 do
-      let _finished, used_in, used_out =
-        Zlib.deflate zlib_str buf !i !len o_buf 0 (Bytes.length o_buf) flush
-      in
-      i := !i + used_in;
-      len := !len - used_in;
-      o_len := !o_len + used_out;
-      write_out oc
-    done
-  in
-
-  let write (oc : Out.t) : unit =
-    let output buf i len = write_zlib ~flush:Zlib.Z_NO_FLUSH oc buf i len in
-
-    let bchar = Bytes.create 1 in
-    let output_char c =
-      Bytes.set bchar 0 c;
-      output bchar 0 1
-    in
-
-    let flush () =
-      flush_zlib oc ~flush:Zlib.Z_FINISH;
-      assert (!o_len = 0);
-      oc.flush ()
-    in
-    let close () =
-      flush ();
-      Zlib.deflate_end zlib_str;
-      oc.close ()
-    in
-    (* new output channel that compresses on the fly *)
-    let oc' = { Out.flush; close; output; output_char } in
-    w.write oc';
-    oc'.close ()
-  in
-
-  W.make ~write ()
-
-let split_on_char ?(f = fun x -> x) c s : string list =
-  let rec loop acc i =
-    match String.index_from s i c with
-    | exception Not_found ->
-      let acc =
-        if i = String.length s then
-          acc
-        else
-          f (String.sub s i (String.length s - i)) :: acc
-      in
-      List.rev acc
-    | j ->
-      let acc = f (String.sub s i (j - i)) :: acc in
-      loop acc (j + 1)
-  in
-  loop [] 0
-
-let accept_deflate (req : _ S.Request.t) =
-  match S.Request.get_header req "Accept-Encoding" with
-  | Some s -> List.mem "deflate" @@ split_on_char ~f:String.trim ',' s
   | None -> false
 
 let has_deflate s =
   try Scanf.sscanf s "deflate, %s" (fun _ -> true) with _ -> false
 
 (* decompress [req]'s body if needed *)
-let decompress_req_stream_ ~buf_size (req : BS.t S.Request.t) : _ S.Request.t =
+let decompress_req_stream_ ~buf_size (req : IO.Input.t Request.t) : _ Request.t
-  match S.Request.get_header ~f:String.trim req "Transfer-Encoding" with
+    =
+  match Request.get_header ~f:String.trim req "Transfer-Encoding" with
   (* TODO
      | Some "gzip" ->
        let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in
        Some (req', decode_gzip_stream_)
   *)
   | Some "deflate" ->
-    let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in
+    let body' = Request.body req |> decode_deflate_stream_ ~buf_size in
-    req
+    req |> Request.remove_header "Transfer-Encoding" |> Request.set_body body'
-    |> S.Request.remove_header "Transfer-Encoding"
-    |> S.Request.set_body body'
   | Some s when has_deflate s ->
     (match Scanf.sscanf s "deflate, %s" (fun s -> s) with
     | tr' ->
-      let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in
+      let body' = Request.body req |> decode_deflate_stream_ ~buf_size in
       req
-      |> S.Request.set_header "Transfer-Encoding" tr'
+      |> Request.set_header "Transfer-Encoding" tr'
-      |> S.Request.set_body body'
+      |> Request.set_body body'
     | exception _ -> req)
   | _ -> req
 
-let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t)
+let compress_resp_stream_ ~compress_above ~buf_size (req : _ Request.t)
-    (resp : S.Response.t) : S.Response.t =
+    (resp : Response.t) : Response.t =
   (* headers for compressed stream *)
   let update_headers h =
     h
-    |> S.Headers.remove "Content-Length"
+    |> Headers.remove "Content-Length"
-    |> S.Headers.set "Content-Encoding" "deflate"
+    |> Headers.set "Content-Encoding" "deflate"
   in
 
   if accept_deflate req then (
@@ -181,25 +65,25 @@ let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t)
             (String.length s) compress_above);
       let body = encode_deflate_writer_ ~buf_size @@ W.of_string s in
       resp
-      |> S.Response.update_headers update_headers
+      |> Response.update_headers update_headers
-      |> S.Response.set_body (`Writer body)
+      |> Response.set_body (`Writer body)
-    | `Stream str ->
+    | `Stream ic ->
       Log.debug (fun k -> k "encode stream response with deflate");
-      let w = BS.to_writer str in
+      let w = IO.Writer.of_input ic in
       resp
-      |> S.Response.update_headers update_headers
+      |> Response.update_headers update_headers
-      |> S.Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
+      |> Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
     | `Writer w ->
       Log.debug (fun k -> k "encode writer response with deflate");
       resp
-      |> S.Response.update_headers update_headers
+      |> Response.update_headers update_headers
-      |> S.Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
+      |> Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w))
     | `String _ | `Void -> resp
   ) else
     resp
 
 let middleware ?(compress_above = 16 * 1024) ?(buf_size = 16 * 1_024) () :
-    S.Middleware.t =
+    Server.Middleware.t =
   let buf_size = max buf_size 1_024 in
   fun h req ~resp ->
     let req = decompress_req_stream_ ~buf_size req in
@@ -209,4 +93,4 @@ let middleware ?(compress_above = 16 * 1024) ?(buf_size = 16 * 1_024) () :
 let setup ?compress_above ?buf_size server =
   let m = middleware ?compress_above ?buf_size () in
   Log.info (fun k -> k "setup gzip middleware");
-  S.add_middleware ~stage:`Encoding server m
+  Server.add_middleware ~stage:`Encoding server m

src/camlzip/Tiny_httpd_camlzip.mli

@@ -7,7 +7,7 @@
   *)
 
 val middleware :
-  ?compress_above:int -> ?buf_size:int -> unit -> Tiny_httpd_server.Middleware.t
+  ?compress_above:int -> ?buf_size:int -> unit -> Server.Middleware.t
 (** Middleware responsible for deflate compression/decompression.
     @param compress_above threshold, in bytes, above which a response body
       that has a known content-length is compressed. Stream bodies
@@ -15,7 +15,7 @@ val middleware :
     @param buf_size size of the underlying buffer for compression/decompression
     @since 0.11 *)
 
-val setup : ?compress_above:int -> ?buf_size:int -> Tiny_httpd_server.t -> unit
+val setup : ?compress_above:int -> ?buf_size:int -> Server.t -> unit
 (** Install middleware for tiny_httpd to be able to encode/decode
     compressed streams
     @param compress_above threshold above with string responses are compressed

src/camlzip/dune

@@ -2,5 +2,5 @@
  (name tiny_httpd_camlzip)
  (public_name tiny_httpd_camlzip)
  (synopsis "A wrapper around camlzip to bring compression to Tiny_httpd")
- (flags :standard -safe-string -warn-error -a+8)
+ (flags :standard -open Tiny_httpd_core -safe-string -warn-error -a+8)
- (libraries tiny_httpd camlzip))
+ (libraries tiny_httpd.core iostream-camlzip camlzip))

src/core/IO.ml

@@ -0,0 +1,478 @@
+(** IO abstraction.
+
+    We abstract IO so we can support classic unix blocking IOs
+    with threads, and modern async IO with Eio.
+
+    {b NOTE}: experimental.
+
+    @since 0.14
+*)
+
+open Common_
+module Buf = Buf
+module Slice = Iostream.Slice
+
+(** Output channel (byte sink) *)
+module Output = struct
+  include Iostream.Out_buf
+
+  class of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
+    (fd : Unix.file_descr) : t =
+    object
+      inherit t_from_output ~bytes:buf.bytes ()
+
+      method private output_underlying bs i len0 =
+        let i = ref i in
+        let len = ref len0 in
+        while !len > 0 do
+          match Unix.write fd bs !i !len with
+          | 0 -> failwith "write failed"
+          | n ->
+            i := !i + n;
+            len := !len - n
+          | exception
+              Unix.Unix_error
+                ( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
+                  | Unix.ECONNRESET | Unix.EPIPE ),
+                  _,
+                  _ ) ->
+            failwith "write failed"
+          | exception
+              Unix.Unix_error
+                ((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
+            ignore (Unix.select [] [ fd ] [] 1.)
+        done
+
+      method private close_underlying () =
+        if not !closed then (
+          closed := true;
+          if close_noerr then (
+            try Unix.close fd with _ -> ()
+          ) else
+            Unix.close fd
+        )
+    end
+
+  let output_buf (self : t) (buf : Buf.t) : unit =
+    let b = Buf.bytes_slice buf in
+    output self b 0 (Buf.size buf)
+
+  (** [chunk_encoding oc] makes a new channel that outputs its content into [oc]
+      in chunk encoding form.
+      @param close_rec if true, closing the result will also close [oc]
+      @param buf a buffer used to accumulate data into chunks.
+        Chunks are emitted when [buf]'s size gets over a certain threshold,
+        or when [flush] is called.
+      *)
+  let chunk_encoding ?(buf = Buf.create ()) ~close_rec (oc : #t) : t =
+    (* write content of [buf] as a chunk if it's big enough.
+       If [force=true] then write content of [buf] if it's simply non empty. *)
+    let write_buf ~force () =
+      let n = Buf.size buf in
+      if (force && n > 0) || n >= 4_096 then (
+        output_string oc (Printf.sprintf "%x\r\n" n);
+        output oc (Buf.bytes_slice buf) 0 n;
+        output_string oc "\r\n";
+        Buf.clear buf
+      )
+    in
+
+    object
+      method flush () =
+        write_buf ~force:true ();
+        flush oc
+
+      method close () =
+        write_buf ~force:true ();
+        (* write an empty chunk to close the stream *)
+        output_string oc "0\r\n";
+        (* write another crlf after the stream (see #56) *)
+        output_string oc "\r\n";
+        flush oc;
+        if close_rec then close oc
+
+      method output b i n =
+        Buf.add_bytes buf b i n;
+        write_buf ~force:false ()
+
+      method output_char c =
+        Buf.add_char buf c;
+        write_buf ~force:false ()
+    end
+end
+
+(** Input channel (byte source) *)
+module Input = struct
+  include Iostream.In_buf
+
+  let of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
+      (fd : Unix.file_descr) : t =
+    let eof = ref false in
+    object
+      inherit Iostream.In_buf.t_from_refill ~bytes:buf.bytes ()
+
+      method private refill (slice : Slice.t) =
+        if not !eof then (
+          slice.off <- 0;
+          let continue = ref true in
+          while !continue do
+            match Unix.read fd slice.bytes 0 (Bytes.length slice.bytes) with
+            | n ->
+              slice.len <- n;
+              continue := false
+            | exception
+                Unix.Unix_error
+                  ( ( Unix.EBADF | Unix.ENOTCONN | Unix.ESHUTDOWN
+                    | Unix.ECONNRESET | Unix.EPIPE ),
+                    _,
+                    _ ) ->
+              eof := true;
+              continue := false
+            | exception
+                Unix.Unix_error
+                  ((Unix.EWOULDBLOCK | Unix.EAGAIN | Unix.EINTR), _, _) ->
+              ignore (Unix.select [ fd ] [] [] 1.)
+          done;
+          (* Printf.eprintf "read returned %d B\n%!" !n; *)
+          if slice.len = 0 then eof := true
+        )
+
+      method close () =
+        if not !closed then (
+          closed := true;
+          eof := true;
+          if close_noerr then (
+            try Unix.close fd with _ -> ()
+          ) else
+            Unix.close fd
+        )
+    end
+
+  let of_slice (slice : Slice.t) : t =
+    object
+      inherit Iostream.In_buf.t_from_refill ~bytes:slice.bytes ()
+
+      method private refill (slice : Slice.t) =
+        slice.off <- 0;
+        slice.len <- 0
+
+      method close () = ()
+    end
+
+  (** Read into the given slice.
+      @return the number of bytes read, [0] means end of input. *)
+  let[@inline] input (self : t) buf i len = self#input buf i len
+
+  (** Close the channel. *)
+  let[@inline] close self : unit = self#close ()
+
+  (** Read exactly [len] bytes.
+      @raise End_of_file if the input did not contain enough data. *)
+  let really_input (self : t) buf i len : unit =
+    let i = ref i in
+    let len = ref len in
+    while !len > 0 do
+      let n = input self buf !i !len in
+      if n = 0 then raise End_of_file;
+      i := !i + n;
+      len := !len - n
+    done
+
+  let append (i1 : #t) (i2 : #t) : t =
+    let use_i1 = ref true in
+    let rec input_rec (slice : Slice.t) =
+      if !use_i1 then (
+        slice.len <- input i1 slice.bytes 0 (Bytes.length slice.bytes);
+        if slice.len = 0 then (
+          use_i1 := false;
+          input_rec slice
+        )
+      ) else
+        slice.len <- input i1 slice.bytes 0 (Bytes.length slice.bytes)
+    in
+
+    object
+      inherit Iostream.In_buf.t_from_refill ()
+
+      method private refill (slice : Slice.t) =
+        slice.off <- 0;
+        input_rec slice
+
+      method close () =
+        close i1;
+        close i2
+    end
+
+  let iter_slice (f : Slice.t -> unit) (self : #t) : unit =
+    let continue = ref true in
+    while !continue do
+      let slice = self#fill_buf () in
+      if slice.len = 0 then (
+        continue := false;
+        close self
+      ) else (
+        f slice;
+        Slice.consume slice slice.len
+      )
+    done
+
+  let iter f self =
+    iter_slice (fun (slice : Slice.t) -> f slice.bytes slice.off slice.len) self
+
+  let to_chan oc (self : #t) =
+    iter_slice
+      (fun (slice : Slice.t) ->
+        Stdlib.output oc slice.bytes slice.off slice.len)
+      self
+
+  let to_chan' (oc : #Iostream.Out.t) (self : #t) : unit =
+    iter_slice
+      (fun (slice : Slice.t) ->
+        Iostream.Out.output oc slice.bytes slice.off slice.len)
+      self
+
+  let read_all_using ~buf (self : #t) : string =
+    Buf.clear buf;
+    let continue = ref true in
+    while !continue do
+      let slice = fill_buf self in
+      if slice.len = 0 then
+        continue := false
+      else (
+        assert (slice.len > 0);
+        Buf.add_bytes buf slice.bytes slice.off slice.len;
+        Slice.consume slice slice.len
+      )
+    done;
+    Buf.contents_and_clear buf
+
+  (** Read [n] bytes from the input into [bytes]. *)
+  let read_exactly_ ~too_short (self : #t) (bytes : bytes) (n : int) : unit =
+    assert (Bytes.length bytes >= n);
+    let offset = ref 0 in
+    while !offset < n do
+      let slice = self#fill_buf () in
+      let n_read = min slice.len (n - !offset) in
+      Bytes.blit slice.bytes slice.off bytes !offset n_read;
+      offset := !offset + n_read;
+      Slice.consume slice n_read;
+      if n_read = 0 then too_short ()
+    done
+
+  (** read a line into the buffer, after clearing it. *)
+  let read_line_into (self : t) ~buf : unit =
+    Buf.clear buf;
+    let continue = ref true in
+    while !continue do
+      let slice = self#fill_buf () in
+      if slice.len = 0 then (
+        continue := false;
+        if Buf.size buf = 0 then raise End_of_file
+      );
+      let j = ref slice.off in
+      while !j < slice.off + slice.len && Bytes.get slice.bytes !j <> '\n' do
+        incr j
+      done;
+      if !j - slice.off < slice.len then (
+        assert (Bytes.get slice.bytes !j = '\n');
+        (* line without '\n' *)
+        Buf.add_bytes buf slice.bytes slice.off (!j - slice.off);
+        (* consume line + '\n' *)
+        Slice.consume slice (!j - slice.off + 1);
+        continue := false
+      ) else (
+        Buf.add_bytes buf slice.bytes slice.off slice.len;
+        Slice.consume slice slice.len
+      )
+    done
+
+  let read_line_using ~buf (self : #t) : string =
+    read_line_into self ~buf;
+    Buf.contents_and_clear buf
+
+  let read_line_using_opt ~buf (self : #t) : string option =
+    match read_line_into self ~buf with
+    | () -> Some (Buf.contents_and_clear buf)
+    | exception End_of_file -> None
+
+  (* helper for making a new input stream that either contains at most [size]
+     bytes, or contains exactly [size] bytes. *)
+  let reading_exactly_ ~skip_on_close ~close_rec ~size ~bytes (arg : t) : t =
+    let remaining_size = ref size in
+
+    object
+      inherit t_from_refill ~bytes ()
+
+      method close () =
+        if !remaining_size > 0 && skip_on_close then skip arg !remaining_size;
+        if close_rec then close arg
+
+      method private refill (slice : Slice.t) =
+        slice.off <- 0;
+        slice.len <- 0;
+        if !remaining_size > 0 then (
+          let sub = fill_buf arg in
+          let n =
+            min !remaining_size (min sub.len (Bytes.length slice.bytes))
+          in
+          Bytes.blit sub.bytes sub.off slice.bytes 0 n;
+          Slice.consume sub n;
+          remaining_size := !remaining_size - n;
+          slice.len <- n
+        )
+    end
+
+  (** new stream with maximum size [max_size].
+   @param close_rec if true, closing this will also close the input stream *)
+  let limit_size_to ~close_rec ~max_size ~bytes (arg : t) : t =
+    reading_exactly_ ~size:max_size ~skip_on_close:false ~bytes ~close_rec arg
+
+  (** New stream that consumes exactly [size] bytes from the input.
+        If fewer bytes are read before [close] is called, we read and discard
+        the remaining quota of bytes before [close] returns.
+   @param close_rec if true, closing this will also close the input stream *)
+  let reading_exactly ~close_rec ~size ~bytes (arg : t) : t =
+    reading_exactly_ ~size ~close_rec ~skip_on_close:true ~bytes arg
+
+  let read_chunked ~(bytes : bytes) ~fail (ic : #t) : t =
+    let first = ref true in
+
+    (* small buffer to read the chunk sizes *)
+    let line_buf = Buf.create ~size:32 () in
+    let read_next_chunk_len () : int =
+      if !first then
+        first := false
+      else (
+        let line = read_line_using ~buf:line_buf ic in
+        if String.trim line <> "" then
+          raise (fail "expected crlf between chunks")
+      );
+      let line = read_line_using ~buf:line_buf ic in
+      (* parse chunk length, ignore extensions *)
+      let chunk_size =
+        if String.trim line = "" then
+          0
+        else (
+          try
+            let off = ref 0 in
+            let n = Parse_.pos_hex line off in
+            n
+          with _ ->
+            raise (fail (spf "cannot read chunk size from line %S" line))
+        )
+      in
+      chunk_size
+    in
+    let eof = ref false in
+    let chunk_size = ref 0 in
+
+    object
+      inherit t_from_refill ~bytes ()
+
+      method private refill (slice : Slice.t) : unit =
+        if !chunk_size = 0 && not !eof then (
+          chunk_size := read_next_chunk_len ();
+          if !chunk_size = 0 then eof := true (* stream is finished *)
+        );
+        slice.off <- 0;
+        slice.len <- 0;
+        if !chunk_size > 0 then (
+          (* read the whole chunk, or [Bytes.length bytes] of it *)
+          let to_read = min !chunk_size (Bytes.length slice.bytes) in
+          read_exactly_
+            ~too_short:(fun () -> raise (fail "chunk is too short"))
+            ic slice.bytes to_read;
+          slice.len <- to_read;
+          chunk_size := !chunk_size - to_read
+        )
+
+      method close () = eof := true (* do not close underlying stream *)
+    end
+
+  (** Output a stream using chunked encoding *)
+  let output_chunked' ?buf (oc : #Iostream.Out_buf.t) (self : #t) : unit =
+    let oc' = Output.chunk_encoding ?buf oc ~close_rec:false in
+    match to_chan' oc' self with
+    | () -> Output.close oc'
+    | exception e ->
+      let bt = Printexc.get_raw_backtrace () in
+      Output.close oc';
+      Printexc.raise_with_backtrace e bt
+
+  (** print a stream as a series of chunks *)
+  let output_chunked ?buf (oc : out_channel) (self : #t) : unit =
+    output_chunked' ?buf (Output.of_out_channel oc) self
+end
+
+(** A writer abstraction. *)
+module Writer = struct
+  type t = { write: Output.t -> unit } [@@unboxed]
+  (** Writer.
+
+    A writer is a push-based stream of bytes.
+    Give it an output channel and it will write the bytes in it.
+
+    This is useful for responses: an http endpoint can return a writer
+    as its response's body; the writer is given access to the connection
+    to the client and can write into it as if it were a regular
+    [out_channel], including controlling calls to [flush].
+    Tiny_httpd will convert these writes into valid HTTP chunks.
+    @since 0.14
+    *)
+
+  let[@inline] make ~write () : t = { write }
+
+  (** Write into the channel. *)
+  let[@inline] write (oc : #Output.t) (self : t) : unit =
+    self.write (oc :> Output.t)
+
+  (** Empty writer, will output 0 bytes. *)
+  let empty : t = { write = ignore }
+
+  (** A writer that just emits the bytes from the given string. *)
+  let[@inline] of_string (str : string) : t =
+    let write oc = Iostream.Out.output_string oc str in
+    { write }
+
+  let[@inline] of_input (ic : #Input.t) : t =
+    { write = (fun oc -> Input.to_chan' oc ic) }
+end
+
+(** A TCP server abstraction. *)
+module TCP_server = struct
+  type conn_handler = {
+    handle: client_addr:Unix.sockaddr -> Input.t -> Output.t -> unit;
+        (** Handle client connection *)
+  }
+
+  type t = {
+    endpoint: unit -> string * int;
+        (** Endpoint we listen on. This can only be called from within [serve]. *)
+    active_connections: unit -> int;
+        (** Number of connections currently active *)
+    running: unit -> bool;  (** Is the server currently running? *)
+    stop: unit -> unit;
+        (** Ask the server to stop. This might not take effect immediately,
+      and is idempotent. After this [server.running()] must return [false]. *)
+  }
+  (** A running TCP server.
+
+     This contains some functions that provide information about the running
+     server, including whether it's active (as opposed to stopped), a function
+     to stop it, and statistics about the number of connections. *)
+
+  type builder = {
+    serve: after_init:(t -> unit) -> handle:conn_handler -> unit -> unit;
+        (** Blocking call to listen for incoming connections and handle them.
+            Uses the connection handler [handle] to handle individual client
+            connections in individual threads/fibers/tasks.
+            @param after_init is called once with the server after the server
+            has started. *)
+  }
+  (** A TCP server builder implementation.
+
+      Calling [builder.serve ~after_init ~handle ()] starts a new TCP server on
+      an unspecified endpoint
+      (most likely coming from the function returning this builder)
+      and returns the running server. *)
+end

src/core/buf.ml

@@ -4,6 +4,7 @@ let create ?(size = 4_096) () : t =
   let bytes = Bytes.make size ' ' in
   { bytes; i = 0; original = bytes }
 
+let of_bytes bytes : t = { bytes; i = 0; original = bytes }
 let[@inline] size self = self.i
 let[@inline] bytes_slice self = self.bytes
 

src/core/buf.mli

@@ -11,6 +11,7 @@ type t
 val size : t -> int
 val clear : t -> unit
 val create : ?size:int -> unit -> t
+val of_bytes : bytes -> t
 val contents : t -> string
 
 val clear_and_zero : t -> unit

src/core/common_.ml

@@ -0,0 +1,10 @@
+exception Bad_req of int * string
+
+let spf = Printf.sprintf
+let bad_reqf c fmt = Printf.ksprintf (fun s -> raise (Bad_req (c, s))) fmt
+
+type 'a resp_result = ('a, int * string) result
+
+let unwrap_resp_result = function
+  | Ok x -> x
+  | Error (c, s) -> raise (Bad_req (c, s))

src/core/dune

@@ -0,0 +1,18 @@
+
+(library
+  (name tiny_httpd_core)
+  (public_name tiny_httpd.core)
+  (private_modules parse_ common_)
+  (libraries threads seq hmap iostream
+             (select log.ml from
+              (logs -> log.logs.ml)
+              (-> log.default.ml))))
+
+(rule
+ (targets Atomic_.ml)
+ (deps
+  (:bin ./gen/mkshims.exe))
+ (action
+  (with-stdout-to
+   %{targets}
+   (run %{bin}))))

src/core/gen/dune

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

src/core/headers.ml

@@ -0,0 +1,70 @@
+open Common_
+
+type t = (string * string) list
+
+let empty = []
+
+let contains name headers =
+  let name' = String.lowercase_ascii name in
+  List.exists (fun (n, _) -> name' = n) headers
+
+let get_exn ?(f = fun x -> x) x h =
+  let x' = String.lowercase_ascii x in
+  List.assoc x' h |> f
+
+let get ?(f = fun x -> x) x h =
+  try Some (get_exn ~f x h) with Not_found -> None
+
+let remove x h =
+  let x' = String.lowercase_ascii x in
+  List.filter (fun (k, _) -> k <> x') h
+
+let set x y h =
+  let x' = String.lowercase_ascii x in
+  (x', y) :: List.filter (fun (k, _) -> k <> x') h
+
+let pp out l =
+  let pp_pair out (k, v) = Format.fprintf out "@[<h>%s: %s@]" k v in
+  Format.fprintf out "@[<v>%a@]" (Format.pp_print_list pp_pair) l
+
+(* token = 1*tchar
+   tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" / "_"
+            / "`" / "|" / "~" / DIGIT / ALPHA ; any VCHAR, except delimiters
+   Reference: https://datatracker.ietf.org/doc/html/rfc7230#section-3.2 *)
+let is_tchar = function
+  | '0' .. '9'
+  | 'a' .. 'z'
+  | 'A' .. 'Z'
+  | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' | '_' | '`'
+  | '|' | '~' ->
+    true
+  | _ -> false
+
+let for_all pred s =
+  try
+    String.iter (fun c -> if not (pred c) then raise Exit) s;
+    true
+  with Exit -> false
+
+let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
+  let rec loop acc =
+    match IO.Input.read_line_using_opt ~buf bs with
+    | None -> raise End_of_file
+    | Some "\r" -> acc
+    | Some line ->
+      Log.debug (fun k -> k "parsed header line %S" line);
+      let k, v =
+        try
+          let i = String.index line ':' in
+          let k = String.sub line 0 i in
+          if not (for_all is_tchar k) then
+            invalid_arg (Printf.sprintf "Invalid header key: %S" k);
+          let v =
+            String.sub line (i + 1) (String.length line - i - 1) |> String.trim
+          in
+          k, v
+        with _ -> bad_reqf 400 "invalid header line: %S" line
+      in
+      loop ((String.lowercase_ascii k, v) :: acc)
+  in
+  loop []

src/core/headers.mli

@@ -0,0 +1,35 @@
+(** Headers
+
+    Headers are metadata associated with a request or response. *)
+
+type t = (string * string) list
+(** The header files of a request or response.
+
+      Neither the key nor the value can contain ['\r'] or ['\n'].
+      See https://tools.ietf.org/html/rfc7230#section-3.2 *)
+
+val empty : t
+(** Empty list of headers.
+      @since 0.5 *)
+
+val get : ?f:(string -> string) -> string -> t -> string option
+(** [get k headers] looks for the header field with key [k].
+      @param f if provided, will transform the value before it is returned. *)
+
+val get_exn : ?f:(string -> string) -> string -> t -> string
+(** @raise Not_found *)
+
+val set : string -> string -> t -> t
+(** [set k v headers] sets the key [k] to value [v].
+      It erases any previous entry for [k] *)
+
+val remove : string -> t -> t
+(** Remove the key from the headers, if present. *)
+
+val contains : string -> t -> bool
+(** Is there a header with the given key? *)
+
+val pp : Format.formatter -> t -> unit
+(** Pretty print the headers. *)
+
+val parse_ : buf:Buf.t -> IO.Input.t -> t

src/core/meth.ml

@@ -0,0 +1,22 @@
+open Common_
+
+type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
+
+let to_string = function
+  | `GET -> "GET"
+  | `PUT -> "PUT"
+  | `HEAD -> "HEAD"
+  | `POST -> "POST"
+  | `DELETE -> "DELETE"
+  | `OPTIONS -> "OPTIONS"
+
+let pp out s = Format.pp_print_string out (to_string s)
+
+let of_string = function
+  | "GET" -> `GET
+  | "PUT" -> `PUT
+  | "POST" -> `POST
+  | "HEAD" -> `HEAD
+  | "DELETE" -> `DELETE
+  | "OPTIONS" -> `OPTIONS
+  | s -> bad_reqf 400 "unknown method %S" s

src/core/meth.mli

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

src/core/pool.ml

@@ -1,4 +1,4 @@
-module A = Tiny_httpd_atomic_
+module A = Atomic_
 
 type 'a list_ = Nil | Cons of int * 'a * 'a list_
 

src/core/request.ml

@@ -0,0 +1,231 @@
+open Common_
+
+type 'body t = {
+  meth: Meth.t;
+  host: string;
+  client_addr: Unix.sockaddr;
+  headers: Headers.t;
+  mutable meta: Hmap.t;
+  http_version: int * int;
+  path: string;
+  path_components: string list;
+  query: (string * string) list;
+  body: 'body;
+  start_time: float;
+}
+
+let headers self = self.headers
+let host self = self.host
+let client_addr self = self.client_addr
+let meth self = self.meth
+let path self = self.path
+let body self = self.body
+let start_time self = self.start_time
+let query self = self.query
+let get_header ?f self h = Headers.get ?f h self.headers
+let remove_header k self = { self with headers = Headers.remove k self.headers }
+let add_meta self k v = self.meta <- Hmap.add k v self.meta
+let get_meta self k = Hmap.find k self.meta
+let get_meta_exn self k = Hmap.get k self.meta
+
+let get_header_int self h =
+  match get_header self h with
+  | Some x -> (try Some (int_of_string x) with _ -> None)
+  | None -> None
+
+let set_header k v self = { self with headers = Headers.set k v self.headers }
+let update_headers f self = { self with headers = f self.headers }
+let set_body b self = { self with body = b }
+
+(** Should we close the connection after this request? *)
+let close_after_req (self : _ t) : bool =
+  match self.http_version with
+  | 1, 1 -> get_header self "connection" = Some "close"
+  | 1, 0 -> not (get_header self "connection" = Some "keep-alive")
+  | _ -> false
+
+let pp_comp_ out comp =
+  Format.fprintf out "[%s]"
+    (String.concat ";" @@ List.map (Printf.sprintf "%S") comp)
+
+let pp_query out q =
+  Format.fprintf out "[%s]"
+    (String.concat ";" @@ List.map (fun (a, b) -> Printf.sprintf "%S,%S" a b) q)
+
+let pp_with ?(mask_header = fun _ -> false)
+    ?(headers_to_mask = [ "authorization"; "cookie" ]) ?(show_query = true)
+    ?(pp_body = fun out _ -> Format.pp_print_string out "?") () out self : unit
+    =
+  let pp_query out q =
+    if show_query then
+      pp_query out q
+    else
+      Format.fprintf out "<hidden>"
+  in
+
+  let headers_to_mask = List.rev_map String.lowercase_ascii headers_to_mask in
+  (* hide some headers *)
+  let headers =
+    List.map
+      (fun (k, v) ->
+        let hidden = List.mem k headers_to_mask || mask_header k in
+        if hidden then
+          k, "<hidden>"
+        else
+          k, v)
+      self.headers
+  in
+  Format.fprintf out
+    "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ body=%a;@ \
+     path_components=%a;@ query=%a@]}"
+    (Meth.to_string self.meth) self.host Headers.pp headers self.path pp_body
+    self.body pp_comp_ self.path_components pp_query self.query
+
+let pp_ out self : unit = pp_with () out self
+
+let pp out self : unit =
+  let pp_body out b = Format.fprintf out "%S" b in
+  pp_with ~pp_body () out self
+
+(* decode a "chunked" stream into a normal stream *)
+let read_stream_chunked_ ~bytes (bs : #IO.Input.t) : IO.Input.t =
+  Log.debug (fun k -> k "body: start reading chunked stream...");
+  IO.Input.read_chunked ~bytes ~fail:(fun s -> Bad_req (400, s)) bs
+
+let limit_body_size_ ~max_size ~bytes (bs : #IO.Input.t) : IO.Input.t =
+  Log.debug (fun k -> k "limit size of body to max-size=%d" max_size);
+  IO.Input.limit_size_to ~max_size ~close_rec:false ~bytes bs
+
+let limit_body_size ~max_size ~bytes (req : IO.Input.t t) : IO.Input.t t =
+  { req with body = limit_body_size_ ~max_size ~bytes req.body }
+
+(** read exactly [size] bytes from the stream *)
+let read_exactly ~size ~bytes (bs : #IO.Input.t) : IO.Input.t =
+  Log.debug (fun k -> k "body: must read exactly %d bytes" size);
+  IO.Input.reading_exactly bs ~close_rec:false ~bytes ~size
+
+(* parse request, but not body (yet) *)
+let parse_req_start ~client_addr ~get_time_s ~buf (bs : IO.Input.t) :
+    unit t option resp_result =
+  try
+    let line = IO.Input.read_line_using ~buf bs in
+    Log.debug (fun k -> k "parse request line: %s" line);
+    let start_time = get_time_s () in
+    let meth, path, version =
+      try
+        let off = ref 0 in
+        let meth = Parse_.word line off in
+        let path = Parse_.word line off in
+        let http_version = Parse_.word line off in
+        let version =
+          match http_version with
+          | "HTTP/1.1" -> 1
+          | "HTTP/1.0" -> 0
+          | v -> invalid_arg (spf "unsupported HTTP version: %s" v)
+        in
+        meth, path, version
+      with
+      | Invalid_argument msg ->
+        Log.error (fun k -> k "invalid request line: `%s`: %s" line msg);
+        raise (Bad_req (400, "Invalid request line"))
+      | _ ->
+        Log.error (fun k -> k "invalid request line: `%s`" line);
+        raise (Bad_req (400, "Invalid request line"))
+    in
+    let meth = Meth.of_string meth in
+    Log.debug (fun k -> k "got meth: %s, path %S" (Meth.to_string meth) path);
+    let headers = Headers.parse_ ~buf bs in
+    let host =
+      match Headers.get "Host" headers with
+      | None -> bad_reqf 400 "No 'Host' header in request"
+      | Some h -> h
+    in
+    let path_components, query = Util.split_query path in
+    let path_components = Util.split_on_slash path_components in
+    let query =
+      match Util.parse_query query with
+      | Ok l -> l
+      | Error e -> bad_reqf 400 "invalid query: %s" e
+    in
+    let req =
+      {
+        meth;
+        query;
+        host;
+        meta = Hmap.empty;
+        client_addr;
+        path;
+        path_components;
+        headers;
+        http_version = 1, version;
+        body = ();
+        start_time;
+      }
+    in
+    Ok (Some req)
+  with
+  | End_of_file | Sys_error _ | Unix.Unix_error _ -> Ok None
+  | Bad_req (c, s) -> Error (c, s)
+  | e -> Error (400, Printexc.to_string e)
+
+(* parse body, given the headers.
+   @param tr_stream a transformation of the input stream. *)
+let parse_body_ ~tr_stream ~bytes (req : IO.Input.t t) :
+    IO.Input.t t resp_result =
+  try
+    let size, has_size =
+      match Headers.get_exn "Content-Length" req.headers |> int_of_string with
+      | n -> n, true (* body of fixed size *)
+      | exception Not_found -> 0, false
+      | exception _ -> bad_reqf 400 "invalid content-length"
+    in
+    let body =
+      match get_header ~f:String.trim req "Transfer-Encoding" with
+      | None -> read_exactly ~size ~bytes @@ tr_stream req.body
+      | Some "chunked" when has_size ->
+        bad_reqf 400 "specifying both transfer-encoding and content-length"
+      | Some "chunked" ->
+        (* body sent by chunks *)
+        let bs : IO.Input.t =
+          read_stream_chunked_ ~bytes @@ tr_stream req.body
+        in
+        if size > 0 then (
+          (* TODO: ensure we recycle [bytes] when the new input is closed *)
+          let bytes = Bytes.create 4096 in
+          limit_body_size_ ~max_size:size ~bytes bs
+        ) else
+          bs
+      | Some s -> bad_reqf 500 "cannot handle transfer encoding: %s" s
+    in
+    Ok { req with body }
+  with
+  | End_of_file -> Error (400, "unexpected end of file")
+  | Bad_req (c, s) -> Error (c, s)
+  | e -> Error (400, Printexc.to_string e)
+
+let read_body_full ?bytes ?buf_size (self : IO.Input.t t) : string t =
+  try
+    let buf =
+      match bytes with
+      | Some b -> Buf.of_bytes b
+      | None -> Buf.create ?size:buf_size ()
+    in
+    let body = IO.Input.read_all_using ~buf self.body in
+    { self with body }
+  with
+  | Bad_req _ as e -> raise e
+  | e -> bad_reqf 500 "failed to read body: %s" (Printexc.to_string e)
+
+module Private_ = struct
+  let close_after_req = close_after_req
+  let parse_req_start = parse_req_start
+
+  let parse_req_start_exn ?(buf = Buf.create ()) ~client_addr ~get_time_s bs =
+    parse_req_start ~client_addr ~get_time_s ~buf bs |> unwrap_resp_result
+
+  let parse_body ?(bytes = Bytes.create 4096) req bs : _ t =
+    parse_body_ ~tr_stream:(fun s -> s) ~bytes { req with body = bs }
+    |> unwrap_resp_result
+
+  let[@inline] set_body body self = { self with body }
+end

src/core/request.mli

@@ -0,0 +1,168 @@
+(** Requests
+
+    Requests are sent by a client, e.g. a web browser or cURL.
+    From the point of view of the server, they're inputs. *)
+
+open Common_
+
+type 'body t = private {
+  meth: Meth.t;  (** HTTP method for this request. *)
+  host: string;
+      (** Host header, mandatory. It can also be found in {!headers}. *)
+  client_addr: Unix.sockaddr;  (** Client address. Available since 0.14. *)
+  headers: Headers.t;  (** List of headers. *)
+  mutable meta: Hmap.t;  (** Metadata. @since NEXT_RELEASE *)
+  http_version: int * int;
+      (** HTTP version. This should be either [1, 0] or [1, 1]. *)
+  path: string;  (** Full path of the requested URL. *)
+  path_components: string list;
+      (** Components of the path of the requested URL. *)
+  query: (string * string) list;  (** Query part of the requested URL. *)
+  body: 'body;  (** Body of the request. *)
+  start_time: float;
+      (** Obtained via [get_time_s] in {!create}
+        @since 0.11 *)
+}
+(** A request with method, path, host, headers, and a body, sent by a client.
+
+      The body is polymorphic because the request goes through
+      several transformations. First it has no body, as only the request
+      and headers are read; then it has a stream body; then the body might be
+      entirely read as a string via {!read_body_full}.
+
+      @since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"]
+      @since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"].
+      @since 0.11 the type is a private alias
+      @since 0.11 the field [start_time] was added
+  *)
+
+val add_meta : _ t -> 'a Hmap.key -> 'a -> unit
+(** Add metadata
+ @since NEXT_RELEASE *)
+
+val get_meta : _ t -> 'a Hmap.key -> 'a option
+(** Get metadata
+ @since NEXT_RELEASE *)
+
+val get_meta_exn : _ t -> 'a Hmap.key -> 'a
+(** Like {!get_meta} but can fail
+    @raise Invalid_argument if not present
+ @since NEXT_RELEASE *)
+
+val pp_with :
+  ?mask_header:(string -> bool) ->
+  ?headers_to_mask:string list ->
+  ?show_query:bool ->
+  ?pp_body:(Format.formatter -> 'body -> unit) ->
+  unit ->
+  Format.formatter ->
+  'body t ->
+  unit
+(** Pretty print the request. The exact format of this printing
+    is not specified.
+    @param mask_header function which is given each header name. If it
+      returns [true], the header's value is masked. The presence of
+      the header is still printed. Default [fun _ -> false].
+    @param headers_to_mask a list of headers masked by default.
+      Default is ["authorization"; "cookie"].
+    @show_query if [true] (default [true]), the query part of the
+      request is shown.
+    @param pp_body body printer (default prints "?" instead of the body,
+      which works even for stream bodies) *)
+
+val pp : Format.formatter -> string t -> unit
+(** Pretty print the request and its body. The exact format of this printing
+      is not specified. *)
+
+val pp_ : Format.formatter -> _ t -> unit
+(** Pretty print the request without its body. The exact format of this printing
+      is not specified. *)
+
+val headers : _ t -> Headers.t
+(** List of headers of the request, including ["Host"]. *)
+
+val get_header : ?f:(string -> string) -> _ t -> string -> string option
+(** [get_header req h] looks up header [h] in [req]. It returns [None] if the
+      header is not present. This is case insensitive and should be used
+      rather than looking up [h] verbatim in [headers]. *)
+
+val get_header_int : _ t -> string -> int option
+(** Same as {!get_header} but also performs a string to integer conversion. *)
+
+val set_header : string -> string -> 'a t -> 'a t
+(** [set_header k v req] sets [k: v] in the request [req]'s headers. *)
+
+val remove_header : string -> 'a t -> 'a t
+(** Remove one instance of this header.
+      @since NEXT_RELEASE *)
+
+val update_headers : (Headers.t -> Headers.t) -> 'a t -> 'a t
+(** Modify headers using the given function.
+      @since 0.11 *)
+
+val set_body : 'a -> _ t -> 'a t
+(** [set_body b req] returns a new query whose body is [b].
+      @since 0.11 *)
+
+val host : _ t -> string
+(** Host field of the request. It also appears in the headers. *)
+
+val client_addr : _ t -> Unix.sockaddr
+(** Client address of the request.
+      @since 0.16 *)
+
+val meth : _ t -> Meth.t
+(** Method for the request. *)
+
+val path : _ t -> string
+(** Request path. *)
+
+val query : _ t -> (string * string) list
+(** Decode the query part of the {!path} field.
+      @since 0.4 *)
+
+val body : 'b t -> 'b
+(** Request body, possibly empty. *)
+
+val start_time : _ t -> float
+(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the request
+      @since 0.11 *)
+
+val limit_body_size :
+  max_size:int -> bytes:bytes -> IO.Input.t t -> IO.Input.t t
+(** Limit the body size to [max_size] bytes, or return
+      a [413] error.
+      @since 0.3
+  *)
+
+val read_body_full : ?bytes:bytes -> ?buf_size:int -> IO.Input.t t -> string t
+(** Read the whole body into a string. Potentially blocking.
+
+    @param buf_size initial size of underlying buffer (since 0.11)
+    @param bytes the initial buffer (since 0.14)
+    *)
+
+(**/**)
+
+(* for internal usage, do not use.  There is no guarantee of stability. *)
+module Private_ : sig
+  val parse_req_start :
+    client_addr:Unix.sockaddr ->
+    get_time_s:(unit -> float) ->
+    buf:Buf.t ->
+    IO.Input.t ->
+    unit t option resp_result
+
+  val parse_req_start_exn :
+    ?buf:Buf.t ->
+    client_addr:Unix.sockaddr ->
+    get_time_s:(unit -> float) ->
+    IO.Input.t ->
+    unit t option
+
+  val close_after_req : _ t -> bool
+  val parse_body : ?bytes:bytes -> unit t -> IO.Input.t -> IO.Input.t t
+  val set_body : 'a -> _ t -> 'a t
+end
+
+(**/**)

src/core/response.ml

@@ -0,0 +1,164 @@
+open Common_
+
+type body =
+  [ `String of string | `Stream of IO.Input.t | `Writer of IO.Writer.t | `Void ]
+
+type t = { code: Response_code.t; headers: Headers.t; body: body }
+
+let set_body body self = { self with body }
+let set_headers headers self = { self with headers }
+let update_headers f self = { self with headers = f self.headers }
+let set_header k v self = { self with headers = Headers.set k v self.headers }
+let remove_header k self = { self with headers = Headers.remove k self.headers }
+let set_code code self = { self with code }
+
+let make_raw ?(headers = []) ~code body : t =
+  (* add content length to response *)
+  let headers =
+    Headers.set "Content-Length" (string_of_int (String.length body)) headers
+  in
+  { code; headers; body = `String body }
+
+let make_raw_stream ?(headers = []) ~code body : t =
+  let headers = Headers.set "Transfer-Encoding" "chunked" headers in
+  { code; headers; body = `Stream body }
+
+let make_raw_writer ?(headers = []) ~code body : t =
+  let headers = Headers.set "Transfer-Encoding" "chunked" headers in
+  { code; headers; body = `Writer body }
+
+let make_void_force_ ?(headers = []) ~code () : t =
+  { code; headers; body = `Void }
+
+let make_void ?(headers = []) ~code () : t =
+  let is_ok = code < 200 || code = 204 || code = 304 in
+  if is_ok then
+    make_void_force_ ~headers ~code ()
+  else
+    make_raw ~headers ~code "" (* invalid to not have a body *)
+
+let make_string ?headers ?(code = 200) r =
+  match r with
+  | Ok body -> make_raw ?headers ~code body
+  | Error (code, msg) -> make_raw ?headers ~code msg
+
+let make_stream ?headers ?(code = 200) r =
+  match r with
+  | Ok body -> make_raw_stream ?headers ~code body
+  | Error (code, msg) -> make_raw ?headers ~code msg
+
+let make_writer ?headers ?(code = 200) r : t =
+  match r with
+  | Ok body -> make_raw_writer ?headers ~code body
+  | Error (code, msg) -> make_raw ?headers ~code msg
+
+let make ?headers ?(code = 200) r : t =
+  match r with
+  | Ok (`String body) -> make_raw ?headers ~code body
+  | Ok (`Stream body) -> make_raw_stream ?headers ~code body
+  | Ok `Void -> make_void ?headers ~code ()
+  | Ok (`Writer f) -> make_raw_writer ?headers ~code f
+  | Error (code, msg) -> make_raw ?headers ~code msg
+
+let fail ?headers ~code fmt =
+  Printf.ksprintf (fun msg -> make_raw ?headers ~code msg) fmt
+
+exception Bad_req = Bad_req
+
+let fail_raise ~code fmt =
+  Printf.ksprintf (fun msg -> raise (Bad_req (code, msg))) fmt
+
+let pp out self : unit =
+  let pp_body out = function
+    | `String s -> Format.fprintf out "%S" s
+    | `Stream _ -> Format.pp_print_string out "<stream>"
+    | `Writer _ -> Format.pp_print_string out "<writer>"
+    | `Void -> ()
+  in
+  Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" self.code
+    Headers.pp self.headers pp_body self.body
+
+let output_ ~bytes (oc : IO.Output.t) (self : t) : unit =
+  (* double indirection:
+     - print into [buffer] using [bprintf]
+     - transfer to [buf_] so we can output from there *)
+  let tmp_buffer = Buffer.create 32 in
+  let buf = Buf.of_bytes bytes in
+
+  (* write start of reply *)
+  Printf.bprintf tmp_buffer "HTTP/1.1 %d %s\r\n" self.code
+    (Response_code.descr self.code);
+  Buf.add_buffer buf tmp_buffer;
+  Buffer.clear tmp_buffer;
+
+  let body, is_chunked =
+    match self.body with
+    | `String s when String.length s > 1024 * 500 ->
+      (* chunk-encode large bodies *)
+      `Writer (IO.Writer.of_string s), true
+    | `String _ as b -> b, false
+    | `Stream _ as b -> b, true
+    | `Writer _ as b -> b, true
+    | `Void as b -> b, false
+  in
+  let headers =
+    if is_chunked then
+      self.headers
+      |> Headers.set "transfer-encoding" "chunked"
+      |> Headers.remove "content-length"
+    else
+      self.headers
+  in
+  let self = { self with headers; body } in
+  Log.debug (fun k ->
+      k "t[%d]: output response: %s"
+        (Thread.id @@ Thread.self ())
+        (Format.asprintf "%a" pp { self with body = `String "<...>" }));
+
+  (* write headers, using [buf] to batch writes *)
+  List.iter
+    (fun (k, v) ->
+      Printf.bprintf tmp_buffer "%s: %s\r\n" k v;
+      Buf.add_buffer buf tmp_buffer;
+      Buffer.clear tmp_buffer)
+    headers;
+
+  IO.Output.output_buf oc buf;
+  IO.Output.output_string oc "\r\n";
+  Buf.clear buf;
+
+  (match body with
+  | `String "" | `Void -> ()
+  | `String s -> IO.Output.output_string oc s
+  | `Writer w ->
+    (* use buffer to chunk encode [w] *)
+    let oc' = IO.Output.chunk_encoding ~buf ~close_rec:false oc in
+    (try
+       IO.Writer.write oc' w;
+       IO.Output.close oc'
+     with e ->
+       let bt = Printexc.get_raw_backtrace () in
+       IO.Output.close oc';
+       IO.Output.flush oc;
+       Printexc.raise_with_backtrace e bt)
+  | `Stream str ->
+    (match IO.Input.output_chunked' ~buf oc str with
+    | () ->
+      Log.debug (fun k ->
+          k "t[%d]: done outputing stream" (Thread.id @@ Thread.self ()));
+      IO.Input.close str
+    | exception e ->
+      let bt = Printexc.get_raw_backtrace () in
+      Log.error (fun k ->
+          k "t[%d]: outputing stream failed with %s"
+            (Thread.id @@ Thread.self ())
+            (Printexc.to_string e));
+      IO.Input.close str;
+      IO.Output.flush oc;
+      Printexc.raise_with_backtrace e bt));
+  IO.Output.flush oc
+
+module Private_ = struct
+  let make_void_force_ = make_void_force_
+  let output_ = output_
+end

src/core/response.mli

@@ -0,0 +1,122 @@
+(** Responses
+
+    Responses are what a http server, such as {!Tiny_httpd}, send back to
+    the client to answer a {!Request.t}*)
+
+type body =
+  [ `String of string | `Stream of IO.Input.t | `Writer of IO.Writer.t | `Void ]
+(** Body of a response, either as a simple string,
+      or a stream of bytes, or nothing (for server-sent events notably).
+
+      - [`String str] replies with a body set to this string, and a known content-length.
+      - [`Stream str] replies with a body made from this string, using chunked encoding.
+      - [`Void] replies with no body.
+      - [`Writer w] replies with a body created by the writer [w], using
+          a chunked encoding.
+        It is available since 0.14.
+  *)
+
+type t = private {
+  code: Response_code.t;  (** HTTP response code. See {!Response_code}. *)
+  headers: Headers.t;
+      (** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *)
+  body: body;  (** Body of the response. Can be empty. *)
+}
+(** A response to send back to a client. *)
+
+val set_body : body -> t -> t
+(** Set the body of the response.
+      @since 0.11 *)
+
+val set_header : string -> string -> t -> t
+(** Set a header.
+      @since 0.11 *)
+
+val update_headers : (Headers.t -> Headers.t) -> t -> t
+(** Modify headers.
+      @since 0.11 *)
+
+val remove_header : string -> t -> t
+(** Remove one instance of this header.
+      @since NEXT_RELEASE *)
+
+val set_headers : Headers.t -> t -> t
+(** Set all headers.
+      @since 0.11 *)
+
+val set_code : Response_code.t -> t -> t
+(** Set the response code.
+      @since 0.11 *)
+
+val make_raw : ?headers:Headers.t -> code:Response_code.t -> string -> t
+(** Make a response from its raw components, with a string body.
+      Use [""] to not send a body at all. *)
+
+val make_raw_stream :
+  ?headers:Headers.t -> code:Response_code.t -> IO.Input.t -> t
+(** Same as {!make_raw} but with a stream body. The body will be sent with
+      the chunked transfer-encoding. *)
+
+val make_void : ?headers:Headers.t -> code:int -> unit -> t
+(** Return a response without a body at all.
+      @since 0.13 *)
+
+val make :
+  ?headers:Headers.t ->
+  ?code:int ->
+  (body, Response_code.t * string) result ->
+  t
+(** [make r] turns a result into a response.
+
+      - [make (Ok body)] replies with [200] and the body.
+      - [make (Error (code,msg))] replies with the given error code
+        and message as body.
+  *)
+
+val make_string :
+  ?headers:Headers.t ->
+  ?code:int ->
+  (string, Response_code.t * string) result ->
+  t
+(** Same as {!make} but with a string body. *)
+
+val make_writer :
+  ?headers:Headers.t ->
+  ?code:int ->
+  (IO.Writer.t, Response_code.t * string) result ->
+  t
+(** Same as {!make} but with a writer body. *)
+
+val make_stream :
+  ?headers:Headers.t ->
+  ?code:int ->
+  (IO.Input.t, Response_code.t * string) result ->
+  t
+(** Same as {!make} but with a stream body. *)
+
+val fail : ?headers:Headers.t -> code:int -> ('a, unit, string, t) format4 -> 'a
+(** Make the current request fail with the given code and message.
+      Example: [fail ~code:404 "oh noes, %s not found" "waldo"].
+  *)
+
+exception Bad_req of int * string
+(** Exception raised by {!fail_raise} with the HTTP code and body *)
+
+val fail_raise : code:int -> ('a, unit, string, 'b) format4 -> 'a
+(** Similar to {!fail} but raises an exception that exits the current handler.
+    This should not be used outside of a (path) handler.
+    Example: [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
+    @raise Bad_req always
+  *)
+
+val pp : Format.formatter -> t -> unit
+(** Pretty print the response. The exact format is not specified. *)
+
+(**/**)
+
+module Private_ : sig
+  val make_void_force_ : ?headers:Headers.t -> code:int -> unit -> t
+  val output_ : bytes:Bytes.t -> IO.Output.t -> t -> unit
+end
+
+(**/**)

src/core/response_code.ml

@@ -0,0 +1,32 @@
+type t = int
+
+let ok = 200
+let not_found = 404
+
+let descr = function
+  | 100 -> "Continue"
+  | 200 -> "OK"
+  | 201 -> "Created"
+  | 202 -> "Accepted"
+  | 204 -> "No content"
+  | 300 -> "Multiple choices"
+  | 301 -> "Moved permanently"
+  | 302 -> "Found"
+  | 304 -> "Not Modified"
+  | 400 -> "Bad request"
+  | 401 -> "Unauthorized"
+  | 403 -> "Forbidden"
+  | 404 -> "Not found"
+  | 405 -> "Method not allowed"
+  | 408 -> "Request timeout"
+  | 409 -> "Conflict"
+  | 410 -> "Gone"
+  | 411 -> "Length required"
+  | 413 -> "Payload too large"
+  | 417 -> "Expectation failed"
+  | 500 -> "Internal server error"
+  | 501 -> "Not implemented"
+  | 503 -> "Service unavailable"
+  | n -> "Unknown response code " ^ string_of_int n (* TODO *)
+
+let[@inline] is_success n = n >= 200 && n < 400

src/core/response_code.mli

@@ -0,0 +1,20 @@
+(** Response Codes *)
+
+type t = int
+(** A standard HTTP code.
+
+      https://tools.ietf.org/html/rfc7231#section-6 *)
+
+val ok : t
+(** The code [200] *)
+
+val not_found : t
+(** The code [404] *)
+
+val descr : t -> string
+(** A description of some of the error codes.
+      NOTE: this is not complete (yet). *)
+
+val is_success : t -> bool
+(** [is_success code] is true iff [code] is in the [2xx] or [3xx] range.
+      @since NEXT_RELEASE *)

src/core/route.ml

@@ -0,0 +1,93 @@
+type path = string list (* split on '/' *)
+
+type (_, _) comp =
+  | Exact : string -> ('a, 'a) comp
+  | Int : (int -> 'a, 'a) comp
+  | String : (string -> 'a, 'a) comp
+  | String_urlencoded : (string -> 'a, 'a) comp
+
+type (_, _) t =
+  | Fire : ('b, 'b) t
+  | Rest : { url_encoded: bool } -> (string -> 'b, 'b) t
+  | Compose : ('a, 'b) comp * ('b, 'c) t -> ('a, 'c) t
+
+let return = Fire
+let rest_of_path = Rest { url_encoded = false }
+let rest_of_path_urlencoded = Rest { url_encoded = true }
+let ( @/ ) a b = Compose (a, b)
+let string = String
+let string_urlencoded = String_urlencoded
+let int = Int
+let exact (s : string) = Exact s
+
+let exact_path (s : string) tail =
+  let rec fn = function
+    | [] -> tail
+    | "" :: ls -> fn ls
+    | s :: ls -> exact s @/ fn ls
+  in
+  fn (String.split_on_char '/' s)
+
+let rec eval : type a b. path -> (a, b) t -> a -> b option =
+ fun path route f ->
+  match path, route with
+  | [], Fire -> Some f
+  | _, Fire -> None
+  | _, Rest { url_encoded } ->
+    let whole_path = String.concat "/" path in
+    (match
+       if url_encoded then (
+         match Util.percent_decode whole_path with
+         | Some s -> s
+         | None -> raise_notrace Exit
+       ) else
+         whole_path
+     with
+    | whole_path -> Some (f whole_path)
+    | exception Exit -> None)
+  | c1 :: path', Compose (comp, route') ->
+    (match comp with
+    | Int ->
+      (match int_of_string c1 with
+      | i -> eval path' route' (f i)
+      | exception _ -> None)
+    | String -> eval path' route' (f c1)
+    | String_urlencoded ->
+      (match Util.percent_decode c1 with
+      | None -> None
+      | Some s -> eval path' route' (f s))
+    | Exact s ->
+      if s = c1 then
+        eval path' route' f
+      else
+        None)
+  | [], Compose (String, Fire) -> Some (f "") (* trailing *)
+  | [], Compose (String_urlencoded, Fire) -> Some (f "") (* trailing *)
+  | [], Compose _ -> None
+
+let bpf = Printf.bprintf
+
+let rec pp_ : type a b. Buffer.t -> (a, b) t -> unit =
+ fun out -> function
+  | Fire -> bpf out "/"
+  | Rest { url_encoded } ->
+    bpf out "<rest_of_url%s>"
+      (if url_encoded then
+        "_urlencoded"
+      else
+        "")
+  | Compose (Exact s, tl) -> bpf out "%s/%a" s pp_ tl
+  | Compose (Int, tl) -> bpf out "<int>/%a" pp_ tl
+  | Compose (String, tl) -> bpf out "<str>/%a" pp_ tl
+  | Compose (String_urlencoded, tl) -> bpf out "<enc_str>/%a" pp_ tl
+
+let to_string x =
+  let b = Buffer.create 16 in
+  pp_ b x;
+  Buffer.contents b
+
+module Private_ = struct
+  let eval = eval
+end
+
+let pp out x = Format.pp_print_string out (to_string x)

src/core/route.mli

@@ -0,0 +1,58 @@
+(** Routing
+
+    Basic type-safe routing of handlers based on URL paths. This is optional,
+    it is possible to only define the root handler with something like
+    {{: https://github.com/anuragsoni/routes/} Routes}.
+    @since 0.6 *)
+
+type ('a, 'b) comp
+(** An atomic component of a path *)
+
+type ('a, 'b) t
+(** A route, composed of path components *)
+
+val int : (int -> 'a, 'a) comp
+(** Matches an integer. *)
+
+val string : (string -> 'a, 'a) comp
+(** Matches a string not containing ['/'] and binds it as is. *)
+
+val string_urlencoded : (string -> 'a, 'a) comp
+(** Matches a URL-encoded string, and decodes it. *)
+
+val exact : string -> ('a, 'a) comp
+(** [exact "s"] matches ["s"] and nothing else. *)
+
+val return : ('a, 'a) t
+(** Matches the empty path. *)
+
+val rest_of_path : (string -> 'a, 'a) t
+(** Matches a string, even containing ['/']. This will match
+      the entirety of the remaining route.
+      @since 0.7 *)
+
+val rest_of_path_urlencoded : (string -> 'a, 'a) t
+(** Matches a string, even containing ['/'], an URL-decode it.
+      This will match the entirety of the remaining route.
+      @since 0.7 *)
+
+val ( @/ ) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t
+(** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"],
+      and [route] matches ["bar/…"]. *)
+
+val exact_path : string -> ('a, 'b) t -> ('a, 'b) t
+(** [exact_path "foo/bar/..." r] is equivalent to
+      [exact "foo" @/ exact "bar" @/ ... @/ r]
+      @since 0.11 **)
+
+val pp : Format.formatter -> _ t -> unit
+(** Print the route.
+      @since 0.7 *)
+
+val to_string : _ t -> string
+(** Print the route.
+      @since 0.7 *)
+
+module Private_ : sig
+  val eval : string list -> ('a, 'b) t -> 'a -> 'b option
+end

src/core/server.ml

@@ -0,0 +1,514 @@
+open Common_
+
+type resp_error = Response_code.t * string
+
+module Middleware = struct
+  type handler = IO.Input.t Request.t -> resp:(Response.t -> unit) -> unit
+  type t = handler -> handler
+
+  (** Apply a list of middlewares to [h] *)
+  let apply_l (l : t list) (h : handler) : handler =
+    List.fold_right (fun m h -> m h) l h
+
+  let[@inline] nil : t = fun h -> h
+end
+
+(* a request handler. handles a single request. *)
+type cb_path_handler = IO.Output.t -> Middleware.handler
+
+module type SERVER_SENT_GENERATOR = sig
+  val set_headers : Headers.t -> unit
+
+  val send_event :
+    ?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
+
+  val close : unit -> unit
+end
+
+type server_sent_generator = (module SERVER_SENT_GENERATOR)
+
+(** Handler that upgrades to another protocol *)
+module type UPGRADE_HANDLER = sig
+  type handshake_state
+  (** Some specific state returned after handshake *)
+
+  val name : string
+  (** Name in the "upgrade" header *)
+
+  val handshake : unit Request.t -> (Headers.t * handshake_state, string) result
+  (** Perform the handshake and upgrade the connection. The returned
+      code is [101] alongside these headers. *)
+
+  val handle_connection :
+    Unix.sockaddr -> handshake_state -> IO.Input.t -> IO.Output.t -> unit
+  (** Take control of the connection and take it from there *)
+end
+
+type upgrade_handler = (module UPGRADE_HANDLER)
+
+exception Upgrade of unit Request.t * upgrade_handler
+
+module type IO_BACKEND = sig
+  val init_addr : unit -> string
+  val init_port : unit -> int
+
+  val get_time_s : unit -> float
+  (** obtain the current timestamp in seconds. *)
+
+  val tcp_server : unit -> IO.TCP_server.builder
+  (** Server  that can listen on a port and handle clients. *)
+end
+
+type handler_result =
+  | Handle of (int * Middleware.t) list * cb_path_handler
+  | Fail of resp_error
+  | Upgrade of upgrade_handler
+
+let unwrap_handler_result req = function
+  | Handle (l, h) -> l, h
+  | Fail (c, s) -> raise (Bad_req (c, s))
+  | Upgrade up -> raise (Upgrade (req, up))
+
+type t = {
+  backend: (module IO_BACKEND);
+  mutable tcp_server: IO.TCP_server.t option;
+  mutable handler: IO.Input.t Request.t -> Response.t;
+      (** toplevel handler, if any *)
+  mutable middlewares: (int * Middleware.t) list;  (** Global middlewares *)
+  mutable middlewares_sorted: (int * Middleware.t) list lazy_t;
+      (** sorted version of {!middlewares} *)
+  mutable path_handlers: (unit Request.t -> handler_result option) list;
+      (** path handlers *)
+  bytes_pool: bytes Pool.t;
+}
+
+let addr (self : t) =
+  match self.tcp_server with
+  | None ->
+    let (module B) = self.backend in
+    B.init_addr ()
+  | Some s -> fst @@ s.endpoint ()
+
+let port (self : t) =
+  match self.tcp_server with
+  | None ->
+    let (module B) = self.backend in
+    B.init_port ()
+  | Some s -> snd @@ s.endpoint ()
+
+let active_connections (self : t) =
+  match self.tcp_server with
+  | None -> 0
+  | Some s -> s.active_connections ()
+
+let sort_middlewares_ l =
+  List.stable_sort (fun (s1, _) (s2, _) -> compare s1 s2) l
+
+let add_middleware ~stage self m =
+  let stage =
+    match stage with
+    | `Encoding -> 0
+    | `Stage n when n < 1 -> invalid_arg "add_middleware: bad stage"
+    | `Stage n -> n
+  in
+  self.middlewares <- (stage, m) :: self.middlewares;
+  self.middlewares_sorted <- lazy (sort_middlewares_ self.middlewares)
+
+let add_decode_request_cb self f =
+  (* turn it into a middleware *)
+  let m h req ~resp =
+    (* see if [f] modifies the stream *)
+    let req0 = Request.Private_.set_body () req in
+    match f req0 with
+    | None -> h req ~resp (* pass through *)
+    | Some (req1, tr_stream) ->
+      let body = tr_stream req.Request.body in
+      let req = Request.set_body body req1 in
+      h req ~resp
+  in
+  add_middleware self ~stage:`Encoding m
+
+let add_encode_response_cb self f =
+  let m h req ~resp =
+    h req ~resp:(fun r ->
+        let req0 = Request.Private_.set_body () req in
+        (* now transform [r] if we want to *)
+        match f req0 r with
+        | None -> resp r
+        | Some r' -> resp r')
+  in
+  add_middleware self ~stage:`Encoding m
+
+let set_top_handler self f = self.handler <- f
+
+(* route the given handler.
+   @param tr_req wraps the actual concrete function returned by the route
+   and makes it into a handler. *)
+let add_route_handler_ ?(accept = fun _req -> Ok ()) ?(middlewares = []) ?meth
+    ~tr_req self (route : _ Route.t) f =
+  let middlewares = List.map (fun h -> 5, h) middlewares in
+  let ph req : handler_result option =
+    match meth with
+    | Some m when m <> req.Request.meth -> None (* ignore *)
+    | _ ->
+      (match Route.Private_.eval req.Request.path_components route f with
+      | Some handler ->
+        (* we have a handler, do we accept the request based on its headers? *)
+        (match accept req with
+        | Ok () ->
+          Some
+            (Handle
+               (middlewares, fun oc req ~resp -> tr_req oc req ~resp handler))
+        | Error err -> Some (Fail err))
+      | None -> None (* path didn't match *))
+  in
+  self.path_handlers <- ph :: self.path_handlers
+
+let add_route_handler (type a) ?accept ?middlewares ?meth self
+    (route : (a, _) Route.t) (f : _) : unit =
+  let tr_req _oc req ~resp f =
+    let req =
+      Pool.with_resource self.bytes_pool @@ fun bytes ->
+      Request.read_body_full ~bytes req
+    in
+    resp (f req)
+  in
+  add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f
+
+let add_route_handler_stream ?accept ?middlewares ?meth self route f =
+  let tr_req _oc req ~resp f = resp (f req) in
+  add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f
+
+let[@inline] _opt_iter ~f o =
+  match o with
+  | None -> ()
+  | Some x -> f x
+
+exception Exit_SSE
+
+let add_route_server_sent_handler ?accept self route f =
+  let tr_req (oc : IO.Output.t) req ~resp f =
+    let req =
+      Pool.with_resource self.bytes_pool @@ fun bytes ->
+      Request.read_body_full ~bytes req
+    in
+    let headers =
+      ref Headers.(empty |> set "content-type" "text/event-stream")
+    in
+
+    (* send response once *)
+    let resp_sent = ref false in
+    let send_response_idempotent_ () =
+      if not !resp_sent then (
+        resp_sent := true;
+        (* send 200 response now *)
+        let initial_resp =
+          Response.Private_.make_void_force_ ~headers:!headers ~code:200 ()
+        in
+        resp initial_resp
+      )
+    in
+
+    let[@inline] writef fmt =
+      Printf.ksprintf (IO.Output.output_string oc) fmt
+    in
+
+    let send_event ?event ?id ?retry ~data () : unit =
+      send_response_idempotent_ ();
+      _opt_iter event ~f:(fun e -> writef "event: %s\n" e);
+      _opt_iter id ~f:(fun e -> writef "id: %s\n" e);
+      _opt_iter retry ~f:(fun e -> writef "retry: %s\n" e);
+      let l = String.split_on_char '\n' data in
+      List.iter (fun s -> writef "data: %s\n" s) l;
+      IO.Output.output_string oc "\n";
+      (* finish group *)
+      IO.Output.flush oc
+    in
+    let module SSG = struct
+      let set_headers h =
+        if not !resp_sent then (
+          headers := List.rev_append h !headers;
+          send_response_idempotent_ ()
+        )
+
+      let send_event = send_event
+      let close () = raise Exit_SSE
+    end in
+    (try f req (module SSG : SERVER_SENT_GENERATOR)
+     with Exit_SSE -> IO.Output.close oc);
+    Log.info (fun k -> k "closed SSE connection")
+  in
+  add_route_handler_ self ?accept ~meth:`GET route ~tr_req f
+
+let add_upgrade_handler ?(accept = fun _ -> Ok ()) (self : t) route f : unit =
+  let ph req : handler_result option =
+    if req.Request.meth <> `GET then
+      None
+    else (
+      match accept req with
+      | Ok () ->
+        (match Route.Private_.eval req.Request.path_components route f with
+        | Some up -> Some (Upgrade up)
+        | None -> None (* path didn't match *))
+      | Error err -> Some (Fail err)
+    )
+  in
+  self.path_handlers <- ph :: self.path_handlers
+
+let clear_bytes_ bs = Bytes.fill bs 0 (Bytes.length bs) '\x00'
+
+let create_from ?(buf_size = 16 * 1_024) ?(middlewares = []) ~backend () : t =
+  let handler _req = Response.fail ~code:404 "no top handler" in
+  let self =
+    {
+      backend;
+      tcp_server = None;
+      handler;
+      path_handlers = [];
+      middlewares = [];
+      middlewares_sorted = lazy [];
+      bytes_pool =
+        Pool.create ~clear:clear_bytes_
+          ~mk_item:(fun () -> Bytes.create buf_size)
+          ();
+    }
+  in
+  List.iter (fun (stage, m) -> add_middleware self ~stage m) middlewares;
+  self
+
+let stop (self : t) =
+  match self.tcp_server with
+  | None -> ()
+  | Some s -> s.stop ()
+
+let running (self : t) =
+  match self.tcp_server with
+  | None -> false
+  | Some s -> s.running ()
+
+let find_map f l =
+  let rec aux f = function
+    | [] -> None
+    | x :: l' ->
+      (match f x with
+      | Some _ as res -> res
+      | None -> aux f l')
+  in
+  aux f l
+
+let string_as_list_contains_ (s : string) (sub : string) : bool =
+  let fragments = String.split_on_char ',' s in
+  List.exists (fun fragment -> String.trim fragment = sub) fragments
+
+(* handle client on [ic] and [oc] *)
+let client_handle_for (self : t) ~client_addr ic oc : unit =
+  Pool.with_resource self.bytes_pool @@ fun bytes_req ->
+  Pool.with_resource self.bytes_pool @@ fun bytes_res ->
+  let (module B) = self.backend in
+
+  (* how to log the response to this query *)
+  let log_response (req : _ Request.t) (resp : Response.t) =
+    if not Log.dummy then (
+      let msgf k =
+        let elapsed = B.get_time_s () -. req.start_time in
+        k
+          ("response to=%s code=%d time=%.3fs meth=%s path=%S" : _ format4)
+          (Util.show_sockaddr client_addr)
+          resp.code elapsed (Meth.to_string req.meth) req.path
+      in
+      if Response_code.is_success resp.code then
+        Log.info msgf
+      else
+        Log.error msgf
+    )
+  in
+
+  let log_exn msg bt =
+    Log.error (fun k ->
+        k "error while processing response for %s msg=%s@.%s"
+          (Util.show_sockaddr client_addr)
+          msg
+          (Printexc.raw_backtrace_to_string bt))
+  in
+
+  (* handle generic exception *)
+  let handle_exn e bt : unit =
+    let msg = Printexc.to_string e in
+    let resp = Response.fail ~code:500 "server error: %s" msg in
+    if not Log.dummy then log_exn msg bt;
+    Response.Private_.output_ ~bytes:bytes_res oc resp
+  in
+
+  let handle_bad_req req e bt =
+    let msg = Printexc.to_string e in
+    let resp = Response.fail ~code:500 "server error: %s" msg in
+    if not Log.dummy then (
+      log_exn msg bt;
+      log_response req resp
+    );
+    Response.Private_.output_ ~bytes:bytes_res oc resp
+  in
+
+  let handle_upgrade req (module UP : UPGRADE_HANDLER) : unit =
+    Log.debug (fun k -> k "upgrade connection");
+    try
+      (* check headers *)
+      (match Request.get_header req "connection" with
+      | Some str when string_as_list_contains_ str "Upgrade" -> ()
+      | _ -> bad_reqf 426 "connection header must contain 'Upgrade'");
+      (match Request.get_header req "upgrade" with
+      | Some u when u = UP.name -> ()
+      | Some u -> bad_reqf 426 "expected upgrade to be '%s', got '%s'" UP.name u
+      | None -> bad_reqf 426 "expected 'connection: upgrade' header");
+
+      (* ok, this is the upgrade we expected *)
+      match UP.handshake req with
+      | Error msg ->
+        (* fail the upgrade *)
+        Log.error (fun k -> k "upgrade failed: %s" msg);
+        let resp = Response.make_raw ~code:429 "upgrade required" in
+        log_response req resp;
+        Response.Private_.output_ ~bytes:bytes_res oc resp
+      | Ok (headers, handshake_st) ->
+        (* send the upgrade reply *)
+        let headers =
+          [ "connection", "upgrade"; "upgrade", UP.name ] @ headers
+        in
+        let resp = Response.make_string ~code:101 ~headers (Ok "") in
+        log_response req resp;
+        Response.Private_.output_ ~bytes:bytes_res oc resp;
+
+        UP.handle_connection client_addr handshake_st ic oc
+    with e ->
+      let bt = Printexc.get_raw_backtrace () in
+      handle_bad_req req e bt
+  in
+
+  let continue = ref true in
+
+  let handle_one_req () =
+    match
+      let buf = Buf.of_bytes bytes_req in
+      Request.Private_.parse_req_start ~client_addr ~get_time_s:B.get_time_s
+        ~buf ic
+    with
+    | Ok None -> continue := false (* client is done *)
+    | Error (c, s) ->
+      (* connection error, close *)
+      let res = Response.make_raw ~code:c s in
+      (try Response.Private_.output_ ~bytes:bytes_res oc res
+       with Sys_error _ -> ());
+      continue := false
+    | Ok (Some req) ->
+      Log.debug (fun k ->
+          k "t[%d]: parsed request: %s"
+            (Thread.id @@ Thread.self ())
+            (Format.asprintf "@[%a@]" Request.pp_ req));
+
+      if Request.Private_.close_after_req req then continue := false;
+
+      (try
+         (* is there a handler for this path? *)
+         let handler_middlewares, base_handler =
+           match find_map (fun ph -> ph req) self.path_handlers with
+           | Some f -> unwrap_handler_result req f
+           | None -> [], fun _oc req ~resp -> resp (self.handler req)
+         in
+
+         (* handle expect/continue *)
+         (match Request.get_header ~f:String.trim req "Expect" with
+         | Some "100-continue" ->
+           Log.debug (fun k -> k "send back: 100 CONTINUE");
+           Response.Private_.output_ ~bytes:bytes_res oc
+             (Response.make_raw ~code:100 "")
+         | Some s -> bad_reqf 417 "unknown expectation %s" s
+         | None -> ());
+
+         (* merge per-request middlewares with the server-global middlewares *)
+         let global_middlewares = Lazy.force self.middlewares_sorted in
+         let all_middlewares =
+           if handler_middlewares = [] then
+             global_middlewares
+           else
+             sort_middlewares_
+               (List.rev_append handler_middlewares self.middlewares)
+         in
+
+         (* apply middlewares *)
+         let handler oc =
+           List.fold_right
+             (fun (_, m) h -> m h)
+             all_middlewares (base_handler oc)
+         in
+
+         (* now actually read request's body into a stream *)
+         let req = Request.Private_.parse_body ~bytes:bytes_req req ic in
+
+         (* how to reply *)
+         let resp r =
+           try
+             if Headers.get "connection" r.Response.headers = Some "close" then
+               continue := false;
+             log_response req r;
+             Response.Private_.output_ ~bytes:bytes_res oc r
+           with Sys_error e ->
+             Log.debug (fun k ->
+                 k "error when writing response: %s@.connection broken" e);
+             continue := false
+         in
+
+         (* call handler *)
+         try handler oc req ~resp
+         with Sys_error e ->
+           Log.debug (fun k ->
+               k "error while handling request: %s@.connection broken" e);
+           continue := false
+       with
+      | Sys_error e ->
+        (* connection broken somehow *)
+        Log.debug (fun k -> k "error: %s@. connection broken" e);
+        continue := false
+      | Bad_req (code, s) ->
+        continue := false;
+        let resp = Response.make_raw ~code s in
+        log_response req resp;
+        Response.Private_.output_ ~bytes:bytes_res oc resp
+      | Upgrade _ as e -> raise e
+      | e ->
+        let bt = Printexc.get_raw_backtrace () in
+        handle_bad_req req e bt)
+  in
+
+  try
+    while !continue && running self do
+      Log.debug (fun k ->
+          k "t[%d]: read next request" (Thread.id @@ Thread.self ()));
+      handle_one_req ()
+    done
+  with
+  | Upgrade (req, up) ->
+    (* upgrades take over the whole connection, we won't process
+       any further request *)
+    handle_upgrade req up
+  | e ->
+    let bt = Printexc.get_raw_backtrace () in
+    handle_exn e bt
+
+let client_handler (self : t) : IO.TCP_server.conn_handler =
+  { IO.TCP_server.handle = client_handle_for self }
+
+let is_ipv6 (self : t) =
+  let (module B) = self.backend in
+  Util.is_ipv6_str (B.init_addr ())
+
+let run_exn ?(after_init = ignore) (self : t) : unit =
+  let (module B) = self.backend in
+  let server = B.tcp_server () in
+  server.serve
+    ~after_init:(fun tcp_server ->
+      self.tcp_server <- Some tcp_server;
+      after_init ())
+    ~handle:(client_handler self) ()
+
+let run ?after_init self : _ result =
+  try Ok (run_exn ?after_init self) with e -> Error e

src/core/server.mli

@@ -0,0 +1,298 @@
+(** HTTP server.
+
+    This module implements a very simple, basic HTTP/1.1 server using blocking
+    IOs and threads.
+
+    It is possible to use a thread pool, see {!create}'s argument [new_thread].
+
+    @since 0.13
+*)
+
+(** {2 Middlewares}
+
+    A middleware can be inserted in a handler to modify or observe
+    its behavior.
+
+    @since 0.11
+*)
+
+module Middleware : sig
+  type handler = IO.Input.t Request.t -> resp:(Response.t -> unit) -> unit
+  (** Handlers are functions returning a response to a request.
+      The response can be delayed, hence the use of a continuation
+      as the [resp] parameter. *)
+
+  type t = handler -> handler
+  (** A middleware is a handler transformation.
+
+      It takes the existing handler [h],
+      and returns a new one which, given a query, modify it or log it
+      before passing it to [h], or fail. It can also log or modify or drop
+      the response. *)
+
+  val nil : t
+  (** Trivial middleware that does nothing. *)
+end
+
+(** {2 Main Server type} *)
+
+type t
+(** A HTTP server. See {!create} for more details. *)
+
+(** A backend that provides IO operations, network operations, etc.
+
+    This is used to decouple tiny_httpd from the scheduler/IO library used to
+    actually open a TCP server and talk to clients. The classic way is
+    based on {!Unix} and blocking IOs, but it's also possible to
+    use an OCaml 5 library using effects and non blocking IOs. *)
+module type IO_BACKEND = sig
+  val init_addr : unit -> string
+  (** Initial TCP address *)
+
+  val init_port : unit -> int
+  (** Initial port *)
+
+  val get_time_s : unit -> float
+  (** Obtain the current timestamp in seconds. *)
+
+  val tcp_server : unit -> IO.TCP_server.builder
+  (** TCP server builder, to create servers that can listen
+      on a port and handle clients. *)
+end
+
+val create_from :
+  ?buf_size:int ->
+  ?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
+  backend:(module IO_BACKEND) ->
+  unit ->
+  t
+(** Create a new webserver using provided backend.
+
+    The server will not do anything until {!run} is called on it.
+    Before starting the server, one can use {!add_path_handler} and
+    {!set_top_handler} to specify how to handle incoming requests.
+
+    @param buf_size size for buffers (since 0.11)
+    @param middlewares see {!add_middleware} for more details.
+
+    @since 0.14
+*)
+
+val addr : t -> string
+(** Address on which the server listens. *)
+
+val is_ipv6 : t -> bool
+(** [is_ipv6 server] returns [true] iff the address of the server is an IPv6 address.
+    @since 0.3 *)
+
+val port : t -> int
+(** Port on which the server listens. Note that this might be different than
+    the port initially given if the port was [0] (meaning that the OS picks a
+    port for us). *)
+
+val active_connections : t -> int
+(** Number of currently active connections. *)
+
+val add_decode_request_cb :
+  t ->
+  (unit Request.t -> (unit Request.t * (IO.Input.t -> IO.Input.t)) option) ->
+  unit
+  [@@deprecated "use add_middleware"]
+(** Add a callback for every request.
+    The callback can provide a stream transformer and a new request (with
+    modified headers, typically).
+    A possible use is to handle decompression by looking for a [Transfer-Encoding]
+    header and returning a stream transformer that decompresses on the fly.
+
+    @deprecated use {!add_middleware} instead
+*)
+
+val add_encode_response_cb :
+  t -> (unit Request.t -> Response.t -> Response.t option) -> unit
+  [@@deprecated "use add_middleware"]
+(** Add a callback for every request/response pair.
+    Similarly to {!add_encode_response_cb} the callback can return a new
+    response, for example to compress it.
+    The callback is given the query with only its headers,
+    as well as the current response.
+
+    @deprecated use {!add_middleware} instead
+*)
+
+val add_middleware :
+  stage:[ `Encoding | `Stage of int ] -> t -> Middleware.t -> unit
+(** Add a middleware to every request/response pair.
+    @param stage specify when middleware applies.
+      Encoding comes first (outermost layer), then stages in increasing order.
+    @raise Invalid_argument if stage is [`Stage n] where [n < 1]
+    @since 0.11
+*)
+
+(** {2 Request handlers} *)
+
+val set_top_handler : t -> (IO.Input.t Request.t -> Response.t) -> unit
+(** Setup a handler called by default.
+
+    This handler is called with any request not accepted by any handler
+    installed via {!add_path_handler}.
+    If no top handler is installed, unhandled paths will return a [404] not found
+
+    This used to take a [string Request.t] but it now takes a [byte_stream Request.t]
+    since 0.14 . Use {!Request.read_body_full} to read the body into
+    a string if needed.
+*)
+
+val add_route_handler :
+  ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
+  ?middlewares:Middleware.t list ->
+  ?meth:Meth.t ->
+  t ->
+  ('a, string Request.t -> Response.t) Route.t ->
+  'a ->
+  unit
+(** [add_route_handler server Route.(exact "path" @/ string @/ int @/ return) f]
+    calls [f "foo" 42 request] when a [request] with path "path/foo/42/"
+    is received.
+
+    Note that the handlers are called in the reverse order of their addition,
+    so the last registered handler can override previously registered ones.
+
+    @param meth if provided, only accept requests with the given method.
+    Typically one could react to [`GET] or [`PUT].
+    @param accept should return [Ok()] if the given request (before its body
+    is read) should be accepted, [Error (code,message)] if it's to be rejected (e.g. because
+    its content is too big, or for some permission error).
+    See the {!http_of_dir} program for an example of how to use [accept] to
+    filter uploads that are too large before the upload even starts.
+    The default always returns [Ok()], i.e. it accepts all requests.
+
+    @since 0.6
+*)
+
+val add_route_handler_stream :
+  ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
+  ?middlewares:Middleware.t list ->
+  ?meth:Meth.t ->
+  t ->
+  ('a, IO.Input.t Request.t -> Response.t) Route.t ->
+  'a ->
+  unit
+(** Similar to {!add_route_handler}, but where the body of the request
+    is a stream of bytes that has not been read yet.
+    This is useful when one wants to stream the body directly into a parser,
+    json decoder (such as [Jsonm]) or into a file.
+    @since 0.6 *)
+
+(** {2 Server-sent events}
+
+    {b EXPERIMENTAL}: this API is not stable yet. *)
+
+(** A server-side function to generate of Server-sent events.
+
+    See {{: https://html.spec.whatwg.org/multipage/server-sent-events.html} the w3c page}
+    and {{: https://jvns.ca/blog/2021/01/12/day-36--server-sent-events-are-cool--and-a-fun-bug/}
+    this blog post}.
+
+    @since 0.9
+  *)
+module type SERVER_SENT_GENERATOR = sig
+  val set_headers : Headers.t -> unit
+  (** Set headers of the response.
+      This is not mandatory but if used at all, it must be called before
+      any call to {!send_event} (once events are sent the response is
+      already sent too). *)
+
+  val send_event :
+    ?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
+  (** Send an event from the server.
+      If data is a multiline string, it will be sent on separate "data:" lines. *)
+
+  val close : unit -> unit
+  (** Close connection.
+      @since 0.11 *)
+end
+
+type server_sent_generator = (module SERVER_SENT_GENERATOR)
+(** Server-sent event generator. This generates events that are forwarded to
+    the client (e.g. the browser).
+    @since 0.9 *)
+
+val add_route_server_sent_handler :
+  ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
+  t ->
+  ('a, string Request.t -> server_sent_generator -> unit) Route.t ->
+  'a ->
+  unit
+(** Add a handler on an endpoint, that serves server-sent events.
+
+    The callback is given a generator that can be used to send events
+    as it pleases. The connection is always closed by the client,
+    and the accepted method is always [GET].
+    This will set the header "content-type" to "text/event-stream" automatically
+    and reply with a 200 immediately.
+    See {!server_sent_generator} for more details.
+
+    This handler stays on the original thread (it is synchronous).
+
+    @since 0.9 *)
+
+(** {2 Upgrade handlers}
+
+    These handlers upgrade the connection to another protocol.
+    @since NEXT_RELEASE *)
+
+(** Handler that upgrades to another protocol.
+  @since NEXT_RELEASE *)
+module type UPGRADE_HANDLER = sig
+  type handshake_state
+  (** Some specific state returned after handshake *)
+
+  val name : string
+  (** Name in the "upgrade" header *)
+
+  val handshake : unit Request.t -> (Headers.t * handshake_state, string) result
+  (** Perform the handshake and upgrade the connection. The returned
+      code is [101] alongside these headers.
+      In case the handshake fails, this only returns [Error log_msg].
+      The connection is closed without further ado. *)
+
+  val handle_connection :
+    Unix.sockaddr -> handshake_state -> IO.Input.t -> IO.Output.t -> unit
+  (** Take control of the connection and take it from ther.e *)
+end
+
+type upgrade_handler = (module UPGRADE_HANDLER)
+(** @since NEXT_RELEASE *)
+
+val add_upgrade_handler :
+  ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
+  t ->
+  ('a, upgrade_handler) Route.t ->
+  'a ->
+  unit
+
+(** {2 Run the server} *)
+
+val running : t -> bool
+(** Is the server running?
+    @since 0.14 *)
+
+val stop : t -> unit
+(** Ask the server to stop. This might not have an immediate effect
+    as {!run} might currently be waiting on IO. *)
+
+val run : ?after_init:(unit -> unit) -> t -> (unit, exn) result
+(** Run the main loop of the server, listening on a socket
+    described at the server's creation time, using [new_thread] to
+    start a thread for each new client.
+
+    This returns [Ok ()] if the server exits gracefully, or [Error e] if
+    it exits with an error.
+
+    @param after_init is called after the server starts listening. since 0.13 .
+*)
+
+val run_exn : ?after_init:(unit -> unit) -> t -> unit
+(** [run_exn s] is like [run s] but re-raises an exception if the server exits
+    with an error.
+    @since 0.14 *)

src/core/stream.ml.tmp

@@ -1,3 +1,4 @@
+(*
 module Buf = Tiny_httpd_buf
 module IO = Tiny_httpd_io
 
@@ -184,36 +185,6 @@ let read_line_into (self : t) ~buf : unit =
     )
   done
 
-(* new stream with maximum size [max_size].
-   @param close_rec if true, closing this will also close the input stream
-   @param too_big called with read size if the max size is reached *)
-let limit_size_to ~close_rec ~max_size ~too_big (arg : t) : t =
-  let size = ref 0 in
-  let continue = ref true in
-  make ~bs:Bytes.empty
-    ~close:(fun _ -> if close_rec then arg.close ())
-    ~fill:(fun res ->
-      if res.len = 0 && !continue then (
-        arg.fill_buf ();
-        res.bs <- arg.bs;
-        res.off <- arg.off;
-        res.len <- arg.len
-      ) else (
-        arg.bs <- Bytes.empty;
-        arg.off <- 0;
-        arg.len <- 0
-      ))
-    ~consume:(fun res n ->
-      size := !size + n;
-      if !size > max_size then (
-        continue := false;
-        too_big !size
-      ) else (
-        arg.consume n;
-        res.off <- res.off + n;
-        res.len <- res.len - n
-      ))
-    ()
 
 (* read exactly [size] bytes from the stream *)
 let read_exactly ~close_rec ~size ~too_short (arg : t) : t =
@@ -320,3 +291,4 @@ let output_chunked' ?buf (oc : IO.Output.t) (self : t) : unit =
 (* print a stream as a series of chunks *)
 let output_chunked ?buf (oc : out_channel) (self : t) : unit =
   output_chunked' ?buf (IO.Output.of_out_channel oc) self
+  *)

src/core/stream.mli.tmp

@@ -64,7 +64,7 @@ val close : t -> unit
 val empty : t
 (** Stream with 0 bytes inside *)
 
-val of_input : ?buf_size:int -> Tiny_httpd_io.Input.t -> t
+val of_input : ?buf_size:int -> Io.Input.t -> t
 (** Make a buffered stream from the given channel.
     @since 0.14 *)
 

src/core/util.ml

@@ -76,6 +76,12 @@ let split_on_slash s : _ list =
   List.rev !l
 
 let parse_query s : (_ list, string) result =
+  let s =
+    (* skip hash if present *)
+    match String.index_opt s '#' with
+    | Some i -> String.sub s (i + 1) (String.length s - i - 1)
+    | None -> s
+  in
   let pairs = ref [] in
   let is_sep_ = function
     | '&' | ';' -> true
@@ -119,3 +125,5 @@ let show_sockaddr = function
   | Unix.ADDR_UNIX f -> f
   | Unix.ADDR_INET (inet, port) ->
     Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet) port
+
+let is_ipv6_str addr : bool = String.contains addr ':'

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

src/dune

@@ -1,30 +1,6 @@
 (library
   (name tiny_httpd)
   (public_name tiny_httpd)
-  (private_modules Tiny_httpd_mime_ Tiny_httpd_parse_)
+  (flags :standard -open Tiny_httpd_core)
-  (libraries threads seq unix
+  (libraries threads seq unix hmap tiny_httpd.core tiny_httpd.html
-             (select Tiny_httpd_mime_.ml from
+             tiny_httpd.unix))
-              (magic-mime -> Tiny_httpd_mime_.magic.ml)
-              ( -> Tiny_httpd_mime_.dummy.ml))
-             (select Tiny_httpd_log.ml from
-              (logs logs.fmt fmt.tty -> Tiny_httpd_log.logs.ml)
-              (-> Tiny_httpd_log.default.ml)))
-  (wrapped false))
-
-(rule
- (targets Tiny_httpd_html_.ml)
- (deps
-  (:bin ./gen/gentags.exe))
- (action
-  (with-stdout-to
-   %{targets}
-   (run %{bin}))))
-
-(rule
- (targets Tiny_httpd_atomic_.ml)
- (deps
-  (:bin ./gen/mkshims.exe))
- (action
-  (with-stdout-to
-   %{targets}
-   (run %{bin}))))

src/gen/dune

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

src/html/Tiny_httpd_html.ml

@@ -6,9 +6,7 @@
     @since 0.12
 *)
 
-module IO = Tiny_httpd_io
+include Html_
-
-include Tiny_httpd_html_
 (** @inline *)
 
 (** Write an HTML element to this output.
@@ -16,7 +14,7 @@ include Tiny_httpd_html_
     be a "html" tag.
     @since 0.14
     *)
-let to_output ?(top = false) (self : elt) (out : IO.Output.t) : unit =
+let to_output ?(top = false) (self : elt) (out : #IO.Output.t) : unit =
   let out = Out.create_of_out out in
   if top then Out.add_string out "<!DOCTYPE html>\n";
   self out;
@@ -56,10 +54,10 @@ let to_out_channel_top = to_output ~top:true
     @param top if true, add a DOCTYPE. See {!to_out_channel}.
     @since 0.14 *)
 let to_writer ?top (self : elt) : IO.Writer.t =
-  let write oc = to_output ?top self oc in
+  let write (oc : #IO.Output.t) = to_output ?top self oc in
   IO.Writer.make ~write ()
 
 (** Convert a HTML element to a stream. This might just convert
     it to a string first, do not assume it to be more efficient. *)
-let to_stream (self : elt) : Tiny_httpd_stream.t =
+let[@inline] to_stream (self : elt) : IO.Input.t =
-  Tiny_httpd_stream.of_string @@ to_string self
+  IO.Input.of_string @@ to_string self

src/html/dune

@@ -0,0 +1,16 @@
+
+
+(library
+  (name tiny_httpd_html)
+  (public_name tiny_httpd.html)
+  (flags :standard -open Tiny_httpd_core)
+  (libraries seq tiny_httpd.core))
+
+(rule
+ (targets html_.ml)
+ (deps
+  (:bin ./gen/gentags.exe))
+ (action
+  (with-stdout-to
+   %{targets}
+   (run %{bin}))))

src/html/gen/dune

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

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

src/prometheus/common_.ml

@@ -1,3 +0,0 @@
-module A = Tiny_httpd_atomic_
-
-let spf = Printf.sprintf

src/prometheus/common_p_.ml

@@ -0,0 +1,3 @@
+module A = Tiny_httpd_core.Atomic_
+
+let spf = Printf.sprintf

src/prometheus/dune

@@ -4,9 +4,10 @@
  (name tiny_httpd_prometheus)
  (public_name tiny_httpd.prometheus)
  (synopsis "Metrics using prometheus")
- (private_modules common_ time_)
+ (private_modules common_p_ time_)
+ (flags :standard -open Tiny_httpd_core)
  (libraries
-  tiny_httpd unix
+  tiny_httpd.core unix
   (select time_.ml from
    (mtime mtime.clock.os -> time_.mtime.ml)
    (-> time_.default.ml))))

src/prometheus/tiny_httpd_prometheus.ml

@@ -2,7 +2,7 @@
   https://prometheus.io/docs/instrumenting/exposition_formats/#text-based-format
   *)
 
-open Common_
+open Common_p_
 
 let bpf = Printf.bprintf
 
@@ -175,9 +175,7 @@ end
 
 let global = Registry.create ()
 
-module H = Tiny_httpd
+let http_middleware (reg : Registry.t) : Server.Middleware.t =
-
-let http_middleware (reg : Registry.t) : H.Middleware.t =
   let c_req =
     Counter.create reg "tiny_httpd_requests" ~descr:"number of HTTP requests"
   in
@@ -189,11 +187,11 @@ let http_middleware (reg : Registry.t) : H.Middleware.t =
       ~buckets:[ 0.001; 0.01; 0.1; 0.5; 1.; 5.; 10. ]
   in
 
-  fun h : H.Middleware.handler ->
+  fun h : Server.Middleware.handler ->
     fun req ~resp : unit ->
      let start = Time_.now_us () in
      Counter.incr c_req;
-     h req ~resp:(fun (response : H.Response.t) ->
+     h req ~resp:(fun (response : Response.t) ->
          let code = response.code in
 
          let elapsed_us = Time_.now_us () -. start in
@@ -203,13 +201,14 @@ let http_middleware (reg : Registry.t) : H.Middleware.t =
          if code < 200 || code >= 400 then Counter.incr c_err;
          resp response)
 
-let add_route_to_server (server : H.t) (reg : registry) : unit =
+let add_route_to_server (server : Server.t) (reg : registry) : unit =
-  H.add_route_handler server H.Route.(exact "metrics" @/ return) @@ fun _req ->
+  Server.add_route_handler server Route.(exact "metrics" @/ return)
+  @@ fun _req ->
   let str = Registry.emit_str reg in
-  H.Response.make_string @@ Ok str
+  Response.make_string @@ Ok str
 
-let instrument_server (server : H.t) reg : unit =
+let instrument_server (server : Server.t) reg : unit =
-  H.add_middleware ~stage:(`Stage 1) server (http_middleware reg);
+  Server.add_middleware ~stage:(`Stage 1) server (http_middleware reg);
   add_route_to_server server reg
 
 module GC_metrics = struct

src/prometheus/tiny_httpd_prometheus.mli

@@ -77,13 +77,13 @@ end
    end
 *)
 
-val http_middleware : Registry.t -> Tiny_httpd.Middleware.t
+val http_middleware : Registry.t -> Server.Middleware.t
 (** Middleware to get basic metrics about HTTP requests *)
 
-val add_route_to_server : Tiny_httpd.t -> Registry.t -> unit
+val add_route_to_server : Server.t -> Registry.t -> unit
 (** Add a "/metrics" route to the server *)
 
-val instrument_server : Tiny_httpd.t -> Registry.t -> unit
+val instrument_server : Server.t -> Registry.t -> unit
 (** Add middleware and route *)
 
 module GC_metrics : sig

src/unix/dir.ml

@@ -1,7 +1,7 @@
-module S = Tiny_httpd_server
+module S = Server
-module U = Tiny_httpd_util
+module U = Util
 module Html = Tiny_httpd_html
-module Log = Tiny_httpd_log
+module Log = Log
 
 type dir_behavior = Index | Lists | Index_or_lists | Forbidden
 type hidden = unit
@@ -78,7 +78,7 @@ module type VFS = sig
   val list_dir : string -> string array
   val delete : string -> unit
   val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
-  val read_file_content : string -> Tiny_httpd_stream.t
+  val read_file_content : string -> IO.Input.t
   val file_size : string -> int option
   val file_mtime : string -> float option
 end
@@ -99,7 +99,8 @@ let vfs_of_dir (top : string) : vfs =
       | { st_kind = Unix.S_REG; _ } ->
         let ic = Unix.(openfile fpath [ O_RDONLY ] 0) in
         let closed = ref false in
-        Tiny_httpd_stream.of_fd_close_noerr ~closed ic
+        let buf = IO.Slice.create 4096 in
+        IO.Input.of_unix_fd ~buf ~close_noerr:true ~closed ic
       | _ -> failwith (Printf.sprintf "not a regular file: %S" f)
 
     let create f =
@@ -216,51 +217,52 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
     : unit =
   let route () =
     if prefix = "" then
-      S.Route.rest_of_path_urlencoded
+      Route.rest_of_path_urlencoded
     else
-      S.Route.exact_path prefix S.Route.rest_of_path_urlencoded
+      Route.exact_path prefix Route.rest_of_path_urlencoded
   in
   if config.delete then
     S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req ->
         if contains_dot_dot path then
-          S.Response.fail_raise ~code:403 "invalid path in delete"
+          Response.fail_raise ~code:403 "invalid path in delete"
         else
-          S.Response.make_string
+          Response.make_string
             (try
                VFS.delete path;
                Ok "file deleted successfully"
              with e -> Error (500, Printexc.to_string e)))
   else
     S.add_route_handler server ~meth:`DELETE (route ()) (fun _ _ ->
-        S.Response.make_raw ~code:405 "delete not allowed");
+        Response.make_raw ~code:405 "delete not allowed");
 
   if config.upload then
     S.add_route_handler_stream server ~meth:`PUT (route ())
       ~accept:(fun req ->
-        match S.Request.get_header_int req "Content-Length" with
+        match Request.get_header_int req "Content-Length" with
         | Some n when n > config.max_upload_size ->
           Error
             (403, "max upload size is " ^ string_of_int config.max_upload_size)
-        | Some _ when contains_dot_dot req.S.Request.path ->
+        | Some _ when contains_dot_dot req.Request.path ->
           Error (403, "invalid path (contains '..')")
         | _ -> Ok ())
       (fun path req ->
         let write, close =
           try VFS.create path
           with e ->
-            S.Response.fail_raise ~code:403 "cannot upload to %S: %s" path
+            Response.fail_raise ~code:403 "cannot upload to %S: %s" path
               (Printexc.to_string e)
         in
         let req =
-          S.Request.limit_body_size ~max_size:config.max_upload_size req
+          Request.limit_body_size ~bytes:(Bytes.create 4096)
+            ~max_size:config.max_upload_size req
         in
-        Tiny_httpd_stream.iter write req.S.Request.body;
+        IO.Input.iter write req.body;
         close ();
         Log.debug (fun k -> k "dir: done uploading file to %S" path);
-        S.Response.make_raw ~code:201 "upload successful")
+        Response.make_raw ~code:201 "upload successful")
   else
     S.add_route_handler server ~meth:`PUT (route ()) (fun _ _ ->
-        S.Response.make_raw ~code:405 "upload not allowed");
+        Response.make_raw ~code:405 "upload not allowed");
 
   if config.download then
     S.add_route_handler server ~meth:`GET (route ()) (fun path req ->
@@ -268,19 +270,18 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
         let mtime =
           lazy
             (match VFS.file_mtime path with
-            | None -> S.Response.fail_raise ~code:403 "Cannot access file"
+            | None -> Response.fail_raise ~code:403 "Cannot access file"
             | Some t -> Printf.sprintf "mtime: %.4f" t)
         in
         if contains_dot_dot path then
-          S.Response.fail ~code:403 "Path is forbidden"
+          Response.fail ~code:403 "Path is forbidden"
         else if not (VFS.contains path) then
-          S.Response.fail ~code:404 "File not found"
+          Response.fail ~code:404 "File not found"
-        else if
+        else if Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
-          S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
         then (
           Log.debug (fun k ->
               k "dir: cached object %S (etag: %S)" path (Lazy.force mtime));
-          S.Response.make_raw ~code:304 ""
+          Response.make_raw ~code:304 ""
         ) else if VFS.is_directory path then (
           Log.debug (fun k -> k "dir: list dir %S (topdir %S)" path VFS.descr);
           let parent = Filename.(dirname path) in
@@ -295,33 +296,36 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
             (* redirect using path, not full path *)
             let new_path = "/" // prefix // path // "index.html" in
             Log.debug (fun k -> k "dir: redirect to `%s`" new_path);
-            S.Response.make_void ~code:301 ()
+            Response.make_void ~code:301 ()
-              ~headers:S.Headers.(empty |> set "location" new_path)
+              ~headers:Headers.(empty |> set "location" new_path)
           | Lists | Index_or_lists ->
             let body =
               html_list_dir ~prefix vfs path ~parent |> Html.to_string_top
             in
-            S.Response.make_string
+            Response.make_string
               ~headers:[ header_html; "ETag", Lazy.force mtime ]
               (Ok body)
           | Forbidden | Index ->
-            S.Response.make_raw ~code:405 "listing dir not allowed"
+            Response.make_raw ~code:405 "listing dir not allowed"
         ) else (
           try
             let mime_type =
-              if Filename.extension path = ".css" then
+              (* FIXME: handle .html specially *)
+              if Filename.extension path = ".html" then
+                [ "Content-Type", "text/html" ]
+              else if Filename.extension path = ".css" then
                 [ "Content-Type", "text/css" ]
               else if Filename.extension path = ".js" then
                 [ "Content-Type", "text/javascript" ]
               else if on_fs then (
                 (* call "file" util *)
-                let ty = Tiny_httpd_mime_.mime_of_path (top // path) in
+                let ty = Mime_.mime_of_path (top // path) in
                 [ "content-type", ty ]
               ) else
                 []
             in
             let stream = VFS.read_file_content path in
-            S.Response.make_raw_stream
+            Response.make_raw_stream
               ~headers:(mime_type @ [ "Etag", Lazy.force mtime ])
               ~code:200 stream
           with e ->
@@ -330,11 +334,11 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
             Log.error (fun k ->
                 k "dir.get failed: %s@.%s" msg
                   (Printexc.raw_backtrace_to_string bt));
-            S.Response.fail ~code:500 "error while reading file: %s" msg
+            Response.fail ~code:500 "error while reading file: %s" msg
         ))
   else
     S.add_route_handler server ~meth:`GET (route ()) (fun _ _ ->
-        S.Response.make_raw ~code:405 "download not allowed");
+        Response.make_raw ~code:405 "download not allowed");
   ()
 
 let add_vfs ~config ~vfs ~prefix server : unit =
@@ -437,7 +441,7 @@ module Embedded_fs = struct
 
       let read_file_content p =
         match find_ self p with
-        | Some (File { content; _ }) -> Tiny_httpd_stream.of_string content
+        | Some (File { content; _ }) -> IO.Input.of_string content
         | _ -> failwith (Printf.sprintf "no such file: %S" p)
 
       let list_dir p =

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 ->
+  config:config -> vfs:(module VFS) -> prefix:string -> Server.t -> unit
-  vfs:(module VFS) ->
-  prefix:string ->
-  Tiny_httpd_server.t ->
-  unit
 (** Similar to {!add_dir_path} but using a virtual file system instead.
     @since 0.12
 *)

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

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

src/unix/tiny_httpd_unix.ml

@@ -0,0 +1,155 @@
+module Dir = Dir
+module Sem = Sem
+
+module Unix_tcp_server_ = struct
+  let get_addr_ sock =
+    match Unix.getsockname sock with
+    | Unix.ADDR_INET (addr, port) -> addr, port
+    | _ -> invalid_arg "httpd: address is not INET"
+
+  type t = {
+    addr: string;
+    port: int;
+    buf_pool: Buf.t Pool.t;
+    slice_pool: IO.Slice.t Pool.t;
+    max_connections: int;
+    sem_max_connections: Sem.t;
+        (** semaphore to restrict the number of active concurrent connections *)
+    mutable sock: Unix.file_descr option;  (** Socket *)
+    new_thread: (unit -> unit) -> unit;
+    timeout: float;
+    masksigpipe: bool;
+    mutable running: bool; (* TODO: use an atomic? *)
+  }
+
+  let shutdown_silent_ fd =
+    try Unix.shutdown fd Unix.SHUTDOWN_ALL with _ -> ()
+
+  let close_silent_ fd = try Unix.close fd with _ -> ()
+
+  let to_tcp_server (self : t) : IO.TCP_server.builder =
+    {
+      IO.TCP_server.serve =
+        (fun ~after_init ~handle () : unit ->
+          if self.masksigpipe then
+            ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list);
+          let sock, should_bind =
+            match self.sock with
+            | Some s ->
+              ( s,
+                false
+                (* Because we're getting a socket from the caller (e.g. systemd) *)
+              )
+            | None ->
+              ( Unix.socket
+                  (if Util.is_ipv6_str self.addr then
+                    Unix.PF_INET6
+                  else
+                    Unix.PF_INET)
+                  Unix.SOCK_STREAM 0,
+                true (* Because we're creating the socket ourselves *) )
+          in
+          Unix.clear_nonblock sock;
+          Unix.setsockopt_optint sock Unix.SO_LINGER None;
+          if should_bind then (
+            let inet_addr = Unix.inet_addr_of_string self.addr in
+            Unix.setsockopt sock Unix.SO_REUSEADDR true;
+            Unix.bind sock (Unix.ADDR_INET (inet_addr, self.port));
+            let n_listen = 2 * self.max_connections in
+            Unix.listen sock n_listen
+          );
+
+          self.sock <- Some sock;
+
+          let tcp_server =
+            {
+              IO.TCP_server.stop = (fun () -> self.running <- false);
+              running = (fun () -> self.running);
+              active_connections =
+                (fun () -> Sem.num_acquired self.sem_max_connections - 1);
+              endpoint =
+                (fun () ->
+                  let addr, port = get_addr_ sock in
+                  Unix.string_of_inet_addr addr, port);
+            }
+          in
+          after_init tcp_server;
+
+          (* how to handle a single client *)
+          let handle_client_unix_ (client_sock : Unix.file_descr)
+              (client_addr : Unix.sockaddr) : unit =
+            Log.debug (fun k ->
+                k "t[%d]: serving new client on %s"
+                  (Thread.id @@ Thread.self ())
+                  (Util.show_sockaddr client_addr));
+
+            if self.masksigpipe then
+              ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list);
+            Unix.set_nonblock client_sock;
+            Unix.setsockopt client_sock Unix.TCP_NODELAY true;
+            Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout);
+            Unix.(setsockopt_float client_sock SO_SNDTIMEO self.timeout);
+
+            Pool.with_resource self.slice_pool @@ fun ic_buf ->
+            Pool.with_resource self.slice_pool @@ fun oc_buf ->
+            let closed = ref false in
+
+            let oc =
+              new IO.Output.of_unix_fd
+                ~close_noerr:true ~closed ~buf:oc_buf client_sock
+            in
+            let ic =
+              IO.Input.of_unix_fd ~close_noerr:true ~closed ~buf:ic_buf
+                client_sock
+            in
+            handle.handle ~client_addr ic oc
+          in
+
+          Unix.set_nonblock sock;
+          while self.running do
+            match Unix.accept sock with
+            | client_sock, client_addr ->
+              (* limit concurrency *)
+              Sem.acquire 1 self.sem_max_connections;
+              (* Block INT/HUP while cloning to avoid children handling them.
+                 When thread gets them, our Unix.accept raises neatly. *)
+              ignore Unix.(sigprocmask SIG_BLOCK Sys.[ sigint; sighup ]);
+              self.new_thread (fun () ->
+                  try
+                    handle_client_unix_ client_sock client_addr;
+                    Log.debug (fun k ->
+                        k "t[%d]: done with client on %s, exiting"
+                          (Thread.id @@ Thread.self ())
+                        @@ Util.show_sockaddr client_addr);
+                    shutdown_silent_ client_sock;
+                    close_silent_ client_sock;
+                    Sem.release 1 self.sem_max_connections
+                  with e ->
+                    let bt = Printexc.get_raw_backtrace () in
+                    shutdown_silent_ client_sock;
+                    close_silent_ client_sock;
+                    Sem.release 1 self.sem_max_connections;
+                    Log.error (fun k ->
+                        k
+                          "@[<v>Handler: uncaught exception for client %s:@ \
+                           %s@ %s@]"
+                          (Util.show_sockaddr client_addr)
+                          (Printexc.to_string e)
+                          (Printexc.raw_backtrace_to_string bt)));
+              ignore Unix.(sigprocmask SIG_UNBLOCK Sys.[ sigint; sighup ])
+            | exception Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _)
+              ->
+              (* wait for the socket to be ready, and re-enter the loop *)
+              ignore (Unix.select [ sock ] [] [ sock ] 1.0 : _ * _ * _)
+            | exception e ->
+              Log.error (fun k ->
+                  k "Unix.accept raised an exception: %s" (Printexc.to_string e));
+              Thread.delay 0.01
+          done;
+
+          (* Wait for all threads to be done: this only works if all threads are done. *)
+          Unix.close sock;
+          Sem.acquire self.sem_max_connections.max self.sem_max_connections;
+          ());
+    }
+end

src/ws/dune

@@ -3,9 +3,10 @@
   (name tiny_httpd_ws)
   (public_name tiny_httpd.ws)
   (synopsis "Websockets for tiny_httpd")
-  (private_modules common_ utils_)
+  (private_modules common_ws_ utils_)
+  (flags :standard -open Tiny_httpd_core)
   (foreign_stubs
     (language c)
     (names tiny_httpd_ws_stubs)
     (flags :standard -std=c99 -fPIC -O2))
-  (libraries tiny_httpd threads))
+  (libraries tiny_httpd.core threads))

src/ws/tiny_httpd_ws.ml

@@ -1,7 +1,4 @@
-open Common_
+open Common_ws_
-open Tiny_httpd_server
-module Log = Tiny_httpd_log
-module IO = Tiny_httpd_io
 
 type handler = Unix.sockaddr -> IO.Input.t -> IO.Output.t -> unit
 
@@ -382,21 +379,23 @@ let upgrade ic oc : _ * _ =
   let writer = Writer.create ~oc () in
   let reader = Reader.create ~ic ~writer () in
   let ws_ic : IO.Input.t =
-    {
+    object
-      input = (fun buf i len -> Reader.read reader buf i len);
+      inherit IO.Input.t_from_refill ~bytes:(Bytes.create 4_096) ()
-      close = (fun () -> Reader.close reader);
+
-    }
+      method private refill (slice : IO.Slice.t) =
+        slice.off <- 0;
+        slice.len <- Reader.read reader slice.bytes 0 (Bytes.length slice.bytes)
+
+      method close () = Reader.close reader
+    end
   in
   let ws_oc : IO.Output.t =
-    {
+    object
-      flush =
+      method close () = Writer.close writer
-        (fun () ->
+      method flush () = Writer.flush writer
-          Writer.flush writer;
+      method output bs i len = Writer.output writer bs i len
-          IO.Output.flush oc);
+      method output_char c = Writer.output_char writer c
-      output_char = Writer.output_char writer;
+    end
-      output = Writer.output writer;
-      close = (fun () -> Writer.close writer);
-    }
   in
   ws_ic, ws_oc
 
@@ -404,7 +403,7 @@ let upgrade ic oc : _ * _ =
 module Make_upgrade_handler (X : sig
   val accept_ws_protocol : string -> bool
   val handler : handler
-end) : UPGRADE_HANDLER = struct
+end) : Server.UPGRADE_HANDLER = struct
   type handshake_state = unit
 
   let name = "websocket"
@@ -454,10 +453,10 @@ end) : UPGRADE_HANDLER = struct
 end
 
 let add_route_handler ?accept ?(accept_ws_protocol = fun _ -> true)
-    (server : Tiny_httpd_server.t) route (f : handler) : unit =
+    (server : Server.t) route (f : handler) : unit =
   let module M = Make_upgrade_handler (struct
     let handler = f
     let accept_ws_protocol = accept_ws_protocol
   end) in
-  let up : upgrade_handler = (module M) in
+  let up : Server.upgrade_handler = (module M) in
-  Tiny_httpd_server.add_upgrade_handler ?accept server route up
+  Server.add_upgrade_handler ?accept server route up

src/ws/tiny_httpd_ws.mli

@@ -4,9 +4,6 @@
     for a websocket server. It has no additional dependencies.
     *)
 
-open Tiny_httpd_server
-module IO = Tiny_httpd_io
-
 type handler = Unix.sockaddr -> IO.Input.t -> IO.Output.t -> unit
 (** Websocket handler *)
 
@@ -16,8 +13,8 @@ val upgrade : IO.Input.t -> IO.Output.t -> IO.Input.t * IO.Output.t
 val add_route_handler :
   ?accept:(unit Request.t -> (unit, int * string) result) ->
   ?accept_ws_protocol:(string -> bool) ->
-  Tiny_httpd_server.t ->
+  Server.t ->
-  (upgrade_handler, upgrade_handler) Route.t ->
+  (Server.upgrade_handler, Server.upgrade_handler) Route.t ->
   handler ->
   unit
 (** Add a route handler for a websocket endpoint.

tests/unit/dune

@@ -2,4 +2,4 @@
 (tests
   (names t_util t_buf t_server)
   (package tiny_httpd)
-  (libraries tiny_httpd qcheck-core qcheck-core.runner test_util))
+  (libraries tiny_httpd.core qcheck-core qcheck-core.runner test_util))

tests/unit/t_buf.ml

@@ -1,5 +1,5 @@
 open Test_util
-open Tiny_httpd_buf
+open Tiny_httpd_core.Buf
 
 let spf = Printf.sprintf
 

tests/unit/t_server.ml

@@ -1,5 +1,5 @@
 open Test_util
-open Tiny_httpd_server
+open Tiny_httpd_core
 
 let () =
   let q =
@@ -9,16 +9,20 @@ let () =
      \r\n\
      salutationsSOMEJUNK"
   in
-  let str = Tiny_httpd.Byte_stream.of_string q in
+  let str = IO.Input.of_string q in
   let client_addr = Unix.(ADDR_INET (inet_addr_loopback, 1024)) in
-  let r = Request.Internal_.parse_req_start ~client_addr ~get_time_s:(fun _ -> 0.) str in
+  let r =
+    Request.Private_.parse_req_start_exn ~client_addr ~buf:(Buf.create ())
+      ~get_time_s:(fun _ -> 0.)
+      str
+  in
   match r with
   | None -> failwith "should parse"
   | Some req ->
-    assert_eq (Some "coucou") (Headers.get "Host" req.Request.headers);
+    assert_eq (Some "coucou") (Headers.get "Host" req.headers);
-    assert_eq (Some "coucou") (Headers.get "host" req.Request.headers);
+    assert_eq (Some "coucou") (Headers.get "host" req.headers);
-    assert_eq (Some "11") (Headers.get "content-length" req.Request.headers);
+    assert_eq (Some "11") (Headers.get "content-length" req.headers);
-    assert_eq "hello" req.Request.path;
+    assert_eq "hello" req.path;
-    let req = Request.Internal_.parse_body req str |> Request.read_body_full in
+    let req = Request.Private_.parse_body req str |> Request.read_body_full in
-    assert_eq ~to_string:(fun s -> s) "salutations" req.Request.body;
+    assert_eq ~to_string:(fun s -> s) "salutations" req.body;
     ()

tests/unit/t_util.ml

@@ -1,33 +1,36 @@
 open Test_util
-open Tiny_httpd_util
+open Tiny_httpd_core
+module U = Util
 
-let () = assert_eq "hello%20world" (percent_encode "hello world")
+let () = assert_eq "hello%20world" (U.percent_encode "hello world")
-let () = assert_eq "%23%25^%24%40^%40" (percent_encode "#%^$@^@")
+let () = assert_eq "%23%25^%24%40^%40" (U.percent_encode "#%^$@^@")
 
 let () =
   assert_eq "a%20ohm%2B5235%25%26%40%23%20---%20_"
-    (percent_encode "a ohm+5235%&@# --- _")
+    (U.percent_encode "a ohm+5235%&@# --- _")
 
-let () = assert_eq (Some "?") (percent_decode @@ percent_encode "?")
+let () = assert_eq (Some "?") (U.percent_decode @@ U.percent_encode "?")
 
 let () =
   add_qcheck
   @@ QCheck.Test.make ~count:1_000 ~long_factor:20 Q.string (fun s ->
          String.iter (fun c -> Q.assume @@ is_ascii_char c) s;
-         match percent_decode (percent_encode s) with
+         match U.percent_decode (U.percent_encode s) with
          | Some s' -> s = s'
          | None -> Q.Test.fail_report "invalid percent encoding")
 
-let () = assert_eq [ "a"; "b" ] (split_on_slash "/a/b")
+let () = assert_eq [ "a"; "b" ] (U.split_on_slash "/a/b")
-let () = assert_eq [ "coucou"; "lol" ] (split_on_slash "/coucou/lol")
+let () = assert_eq [ "coucou"; "lol" ] (U.split_on_slash "/coucou/lol")
-let () = assert_eq [ "a"; "b"; "c" ] (split_on_slash "/a/b//c/")
+let () = assert_eq [ "a"; "b"; "c" ] (U.split_on_slash "/a/b//c/")
-let () = assert_eq [ "a"; "b" ] (split_on_slash "//a/b/")
+let () = assert_eq [ "a"; "b" ] (U.split_on_slash "//a/b/")
-let () = assert_eq [ "a" ] (split_on_slash "/a//")
+let () = assert_eq [ "a" ] (U.split_on_slash "/a//")
-let () = assert_eq [] (split_on_slash "/")
+let () = assert_eq [] (U.split_on_slash "/")
-let () = assert_eq [] (split_on_slash "//")
+let () = assert_eq [] (U.split_on_slash "//")
 
 let () =
-  assert_eq ~cmp:eq_sorted (Ok [ "a", "b"; "c", "d" ]) (parse_query "a=b&c=d")
+  assert_eq ~cmp:eq_sorted (Ok [ "a", "b"; "c", "d" ]) (U.parse_query "a=b&c=d")
+
+let () = assert_eq (Ok [ "foo", "bar" ]) (U.parse_query "yolo#foo=bar")
 
 let () =
   add_qcheck
@@ -43,9 +46,9 @@ let () =
          let s =
            String.concat "&"
              (List.map
-                (fun (x, y) -> percent_encode x ^ "=" ^ percent_encode y)
+                (fun (x, y) -> U.percent_encode x ^ "=" ^ U.percent_encode y)
                 l)
          in
-         eq_sorted (Ok l) (parse_query s))
+         eq_sorted (Ok l) (U.parse_query s))
 
 let () = run_qcheck_and_exit ()

tests/unit/util/dune

@@ -2,4 +2,4 @@
 (library
   (name test_util)
   (modules test_util)
-  (libraries qcheck-core qcheck-core.runner))
+  (libraries logs qcheck-core qcheck-core.runner))

tests/unit/util/test_util.ml

@@ -29,3 +29,7 @@ let add_qcheck f = qchecks := f :: !qchecks
 
 let run_qcheck_and_exit () : 'a =
   exit @@ QCheck_base_runner.run_tests ~colors:false !qchecks
+
+let setup_logs_debug () =
+  Logs.set_reporter @@ Logs.format_reporter ();
+  Logs.set_level ~all:true @@ Some Logs.Debug

tiny_httpd.opam

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

tiny_httpd_camlzip.opam

@@ -11,6 +11,7 @@ depends: [
   "dune" {>= "2.9"}
   "tiny_httpd" {= version}
   "camlzip" {>= "1.06"}
+  "iostream-camlzip"
   "logs" {with-test}
   "odoc" {with-doc}
 ]

vendor/iostream

@@ -0,0 +1 @@
+Subproject commit 668a7c22c09d21293c9ce3fd8bc66b3080c525d2