Merge a56dd0ec65 into ba19880d75

* fix: use realpath to validate filesystem paths against traversal

- add string_prefix helper to check path containment
- compute root_canonical once per add_vfs_ call
- use realpath only for filesystem (on_fs=true), keeping simple
  contains_dot_dot check for VFS
- paths are already URL-decoded by Route.rest_of_path_urlencoded

* fix: add header size limits to prevent memory exhaustion

add optional limits to Headers.parse_:
- max_headers: 100 (default)
- max_header_size: 16KiB per header (default)
- max_total_size: 256KiB total (default)

returns 431 status code when limits exceeded per RFC 6585.

.github/workflows/format.yml

@@ -0,0 +1,27 @@
+name: format
+
+on:
+  pull_request:
+  push:
+    branches:
+      - main
+
+  format:
+    name: format
+    strategy:
+      matrix:
+        ocaml-compiler:
+            - '5.3'
+    runs-on: 'ubuntu-latest'
+    steps:
+      - uses: actions/checkout@main
+      - name: Use OCaml ${{ matrix.ocaml-compiler }}
+        uses: ocaml/setup-ocaml@v3
+        with:
+          ocaml-compiler: ${{ matrix.ocaml-compiler }}
+          dune-cache: true
+          allow-prerelease-opam: true
+
+      - run: opam install ocamlformat.0.27.0
+      - run: opam exec -- make format-check
+

.github/workflows/main.yml

@@ -16,7 +16,7 @@ jobs:
             #- macos-latest
             #- windows-latest
         ocaml-compiler:
-          - 4.08.x
+          - 4.13.x
           - 4.14.x
           - 5.03.x
 

.gitignore

@@ -3,3 +3,5 @@ _build
 _opam
 *.install
 .merlin
+todo.md
+*.tmp

dune-project

@@ -23,7 +23,7 @@
     result
     hmap
     (iostream (>= 0.2))
-    (ocaml (>= 4.08))
+    (ocaml (>= 4.13))
     (odoc :with-doc)
     (logs :with-test)
     (conf-libcurl :with-test)
@@ -39,3 +39,14 @@
     (iostream-camlzip (>= 0.2.1))
     (logs :with-test)
     (odoc :with-doc)))
+
+(package
+  (name tiny_httpd_moonpool)
+  (synopsis "Moonpool+picos_stdio backend for Tiny_httpd")
+  (depends
+    seq
+    (tiny_httpd (= :version))
+    (moonpool (>= 0.7))
+    (moonpool-io (>= 0.7))
+    (ocaml (>= 5.0))
+    (odoc :with-doc)))

echo_mio.sh

@@ -0,0 +1,2 @@
+#!/bin/sh
+exec dune exec --display=quiet --profile=release "examples/echo_mio.exe" -- $@

examples/dune

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

examples/echo.ml

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

examples/echo_mio.ml

@@ -0,0 +1,294 @@
+open Tiny_httpd_core
+module Log = Tiny_httpd.Log
+
+let now_ = Unix.gettimeofday
+
+let alice_text =
+  "CHAPTER I. Down the Rabbit-Hole  Alice was beginning to get very tired of \
+   sitting by her sister on the bank, and of having nothing to do: once or \
+   twice she had peeped into the book her sister was reading, but it had no \
+   pictures or conversations in it, <and what is the use of a book,> thought \
+   Alice <without pictures or conversations?> So she was considering in her \
+   own mind (as well as she could, for the hot day made her feel very sleepy \
+   and stupid), whether the pleasure of making a daisy-chain would be worth \
+   the trouble of getting up and picking the daisies, when suddenly a White \
+   Rabbit with pink eyes ran close by her. There was nothing so very \
+   remarkable in that; nor did Alice think it so very much out of the way to \
+   hear the Rabbit say to itself, <Oh dear! Oh dear! I shall be late!> (when \
+   she thought it over afterwards, it occurred to her that she ought to have \
+   wondered at this, but at the time it all seemed quite natural); but when \
+   the Rabbit actually took a watch out of its waistcoat-pocket, and looked at \
+   it, and then hurried on, Alice started to her feet, for it flashed across \
+   her mind that she had never before seen a rabbit with either a \
+   waistcoat-pocket, or a watch to take out of it, and burning with curiosity, \
+   she ran across the field after it, and fortunately was just in time to see \
+   it pop down a large rabbit-hole under the hedge. In another moment down \
+   went Alice after it, never once considering how in the world she was to get \
+   out again. The rabbit-hole went straight on like a tunnel for some way, and \
+   then dipped suddenly down, so suddenly that Alice had not a moment to think \
+   about stopping herself before she found herself falling down a very deep \
+   well. Either the well was very deep, or she fell very slowly, for she had \
+   plenty of time as she went down to look about her and to wonder what was \
+   going to happen next. First, she tried to look down and make out what she \
+   was coming to, but it was too dark to see anything; then she looked at the \
+   sides of the well, and noticed that they were filled with cupboards......"
+
+(* util: a little middleware collecting statistics *)
+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
+  let build_time_ = ref 0. in
+  let write_time_ = ref 0. in
+
+  let m h req ~resp =
+    incr n_req;
+    let t1 = Request.start_time req in
+    let t2 = now_ () in
+    h req ~resp:(fun response ->
+        let t3 = now_ () in
+        resp response;
+        let t4 = now_ () in
+        total_time_ := !total_time_ +. (t4 -. t1);
+        parse_time_ := !parse_time_ +. (t2 -. t1);
+        build_time_ := !build_time_ +. (t3 -. t2);
+        write_time_ := !write_time_ +. (t4 -. t3))
+  and get_stat () =
+    Printf.sprintf
+      "%d requests (average response time: %.3fms = %.3fms + %.3fms + %.3fms)"
+      !n_req
+      (!total_time_ /. float !n_req *. 1e3)
+      (!parse_time_ /. float !n_req *. 1e3)
+      (!build_time_ /. float !n_req *. 1e3)
+      (!write_time_ /. float !n_req *. 1e3)
+  in
+  m, get_stat
+
+(* ugly AF *)
+let base64 x =
+  let ic, oc = Unix.open_process "base64" in
+  output_string oc x;
+  flush oc;
+  close_out oc;
+  let r = input_line ic in
+  ignore (Unix.close_process (ic, oc));
+  r
+
+let setup_logging () =
+  Logs.set_reporter @@ Logs.format_reporter ();
+  Logs.set_level ~all:true (Some Logs.Debug)
+
+let () =
+  Moonpool_fib.main @@ fun _ ->
+  let port_ = ref 8080 in
+  let max_conn = ref 800 in
+  let j = ref 16 in
+  Arg.parse
+    (Arg.align
+       [
+         "--port", Arg.Set_int port_, " set port";
+         "-p", Arg.Set_int port_, " set port";
+         "--debug", Arg.Unit setup_logging, " enable debug";
+         ( "--max-connections",
+           Arg.Set_int max_conn,
+           " maximum number of connections" );
+         "-j", Arg.Set_int j, " Size of thread pool";
+       ])
+    (fun _ -> raise (Arg.Bad ""))
+    "echo [option]*";
+
+  let runner = Moonpool.Ws_pool.create ~num_threads:!j () in
+  let server : Server.t =
+    Tiny_httpd_moonpool.create ~runner ~port:!port_ ~max_connections:!max_conn
+      ()
+  in
+
+  let m_stats, get_stats = middleware_stat () in
+  Server.add_middleware server ~stage:(`Stage 1) m_stats;
+
+  (* say hello *)
+  Server.add_route_handler ~meth:`GET server
+    Route.(exact "hello" @/ string @/ return)
+    (fun name _req -> Response.make_string (Ok ("hello " ^ name ^ "!\n")));
+
+  (* compressed file access *)
+  Server.add_route_handler ~meth:`GET server
+    Route.(exact "zcat" @/ string_urlencoded @/ return)
+    (fun path _req ->
+      let ic = open_in path 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
+          try
+            let s = [ "Content-Type", String.trim (input_line p) ] in
+            ignore @@ Unix.close_process_in p;
+            s
+          with _ ->
+            ignore @@ Unix.close_process_in p;
+            []
+        with _ -> []
+      in
+      Response.make_stream ~headers:mime_type (Ok str));
+
+  (* echo request *)
+  Server.add_route_handler server
+    Route.(exact "echo" @/ return)
+    (fun req ->
+      let q =
+        Request.query req
+        |> List.map (fun (k, v) -> Printf.sprintf "%S = %S" k v)
+        |> String.concat ";"
+      in
+      Response.make_string
+        (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." Request.pp req q)));
+
+  (* file upload *)
+  Server.add_route_handler_stream ~meth:`PUT server
+    Route.(exact "upload" @/ string @/ return)
+    (fun path req ->
+      Log.debug (fun k ->
+          k "start upload %S, headers:\n%s\n\n%!" path
+            (Format.asprintf "%a" Headers.pp (Request.headers req)));
+      try
+        let oc = open_out @@ "/tmp/" ^ path in
+        IO.Input.to_chan oc req.Request.body;
+        flush oc;
+        Response.make_string (Ok "uploaded file")
+      with e ->
+        Response.fail ~code:500 "couldn't upload file: %s"
+          (Printexc.to_string e));
+
+  (* protected by login *)
+  Server.add_route_handler server
+    Route.(exact "protected" @/ return)
+    (fun req ->
+      let ok =
+        match Request.get_header req "authorization" with
+        | Some v ->
+          Log.debug (fun k -> k "authenticate with %S" v);
+          v = "Basic " ^ base64 "user:foobar"
+        | None -> false
+      in
+      if ok then (
+        (* FIXME: a logout link *)
+        let s =
+          "<p>hello, this is super secret!</p><a href=\"/logout\">log out</a>"
+        in
+        Response.make_string (Ok s)
+      ) else (
+        let headers =
+          Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"")
+        in
+        Response.fail ~code:401 ~headers "invalid"
+      ));
+
+  (* logout *)
+  Server.add_route_handler server
+    Route.(exact "logout" @/ return)
+    (fun _req -> Response.fail ~code:401 "logged out");
+
+  (* stats *)
+  Server.add_route_handler server
+    Route.(exact "stats" @/ return)
+    (fun _req ->
+      let stats = get_stats () in
+      Response.make_string @@ Ok stats);
+
+  Server.add_route_handler server
+    Route.(exact "alice" @/ return)
+    (fun _req -> Response.make_string (Ok alice_text));
+
+  Server.add_route_handler server
+    Route.(exact "alice10" @/ return)
+    (fun _req ->
+      let writer =
+        IO.Writer.make () ~write:(fun oc ->
+            for _i = 1 to 10 do
+              IO.Output.output_string oc alice_text;
+              IO.Output.flush oc
+            done)
+      in
+      Response.make_writer (Ok writer));
+
+  (* main page *)
+  Server.add_route_handler server
+    Route.(return)
+    (fun _req ->
+      let open Tiny_httpd_html in
+      let h =
+        html []
+          [
+            head [] [ title [] [ txt "index of echo" ] ];
+            body []
+              [
+                h3 [] [ txt "welcome!" ];
+                p [] [ b [] [ txt "endpoints are:" ] ];
+                ul []
+                  [
+                    li [] [ pre [] [ txt "/hello/:name (GET)" ] ];
+                    li []
+                      [
+                        pre []
+                          [
+                            a [ A.href "/echo/" ] [ txt "echo" ];
+                            txt " echo back query";
+                          ];
+                      ];
+                    li []
+                      [ pre [] [ txt "/upload/:path (PUT) to upload a file" ] ];
+                    li []
+                      [
+                        pre []
+                          [
+                            txt
+                              "/zcat/:path (GET) to download a file (deflate \
+                               transfer-encoding)";
+                          ];
+                      ];
+                    li []
+                      [
+                        pre []
+                          [
+                            a [ A.href "/stats/" ] [ txt "/stats/" ];
+                            txt " (GET) to access statistics";
+                          ];
+                      ];
+                    li []
+                      [
+                        pre []
+                          [
+                            a [ A.href "/vfs/" ] [ txt "/vfs" ];
+                            txt " (GET) to access a VFS embedded in the binary";
+                          ];
+                      ];
+                    li []
+                      [
+                        pre []
+                          [
+                            a [ A.href "/protected" ] [ txt "/protected" ];
+                            txt
+                              " (GET) to see a protected page (login: user, \
+                               password: foobar)";
+                          ];
+                      ];
+                    li []
+                      [
+                        pre []
+                          [
+                            a [ A.href "/logout" ] [ txt "/logout" ];
+                            txt " (POST) to log out";
+                          ];
+                      ];
+                  ];
+              ];
+          ]
+      in
+      let s = to_string_top h in
+      Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok s);
+
+  Printf.printf "listening on http://%s:%d\n%!" (Server.addr server)
+    (Server.port server);
+  match Server.run server with
+  | Ok () -> ()
+  | Error e -> raise e

examples/echo_ws.ml

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

examples/sse_server.ml

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

src/Tiny_httpd.mli

@@ -1,8 +1,8 @@
 (** Tiny Http Server
 
     This library implements a very simple, basic HTTP/1.1 server using blocking
-    IOs and threads. Basic routing based is provided for convenience,
+    IOs and threads. Basic routing based is provided for convenience, so that
-    so that several handlers can be registered.
+    several handlers can be registered.
 
     It is possible to use a thread pool, see {!create}'s argument [new_thread].
 
@@ -10,74 +10,71 @@
     features by declaring a few endpoints, including one for uploading files:
 
     {[
-module S = Tiny_httpd
+      module S = Tiny_httpd
 
-let () =
+      let () =
-  let server = S.create () in
+        let server = S.create () in
 
-  (* say hello *)
+        (* say hello *)
-  S.add_route_handler ~meth:`GET server
+        S.add_route_handler ~meth:`GET server
-    S.Route.(exact "hello" @/ string @/ return)
+          S.Route.(exact "hello" @/ string @/ return)
-    (fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n")));
+          (fun name _req ->
+            S.Response.make_string (Ok ("hello " ^ name ^ "!\n")));
 
-  (* echo request *)
+        (* echo request *)
-  S.add_route_handler server
+        S.add_route_handler server
-    S.Route.(exact "echo" @/ return)
+          S.Route.(exact "echo" @/ return)
-    (fun req -> S.Response.make_string
+          (fun req ->
-        (Ok (Format.asprintf "echo:@ %a@." S.Request.pp req)));
+            S.Response.make_string
+              (Ok (Format.asprintf "echo:@ %a@." S.Request.pp req)));
 
-  (* file upload *)
+        (* file upload *)
-  S.add_route_handler ~meth:`PUT server
+        S.add_route_handler ~meth:`PUT server
-    S.Route.(exact "upload" @/ string_urlencoded @/ return)
+          S.Route.(exact "upload" @/ string_urlencoded @/ return)
-    (fun path req ->
+          (fun path req ->
-        try
+            try
-          let oc = open_out @@ "/tmp/" ^ path in
+              let oc = open_out @@ "/tmp/" ^ path in
-          output_string oc req.S.Request.body;
+              output_string oc req.S.Request.body;
-          flush oc;
+              flush oc;
-          S.Response.make_string (Ok "uploaded file")
+              S.Response.make_string (Ok "uploaded file")
-        with e ->
+            with e ->
-          S.Response.fail ~code:500 "couldn't upload file: %s"
+              S.Response.fail ~code:500 "couldn't upload file: %s"
-            (Printexc.to_string e)
+                (Printexc.to_string e));
-      );
 
-  (* run the server *)
+        (* run the server *)
-  Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
+        Printf.printf "listening on http://%s:%d\n%!" (S.addr server)
-  match S.run server with
+          (S.port server);
-  | Ok () -> ()
+        match S.run server with
-  | Error e -> raise e
+        | Ok () -> ()
+        | Error e -> raise e
     ]}
 
     It is then possible to query it using curl:
 
     {[
-$ dune exec src/examples/echo.exe &
+      $ dune exec src/examples/echo.exe &
-listening on http://127.0.0.1:8080
+      listening on http://127.0.0.1:8080
 
-# the path "hello/name" greets you.
+      # the path "hello/name" greets you.
-$ curl -X GET http://localhost:8080/hello/quadrarotaphile
+      $ curl -X GET http://localhost:8080/hello/quadrarotaphile
-hello quadrarotaphile!
+      hello quadrarotaphile!
 
-# the path "echo" just prints the request.
+      # the path "echo" just prints the request.
-$ curl -X GET http://localhost:8080/echo --data "howdy y'all"
+      $ curl -X GET http://localhost:8080/echo --data "howdy y'all"
-echo:
+      echo:
-{meth=GET;
+      {meth=GET;
- headers=Host: localhost:8080
+       headers=Host: localhost:8080
-         User-Agent: curl/7.66.0
+               User-Agent: curl/7.66.0
-         Accept: */*
+               Accept: */*
-         Content-Length: 10
+               Content-Length: 10
-         Content-Type: application/x-www-form-urlencoded;
+               Content-Type: application/x-www-form-urlencoded;
- path="/echo"; body="howdy y'all"}
+       path="/echo"; body="howdy y'all"}
-
+    ]} *)
-
-    ]}
-
-*)
 
 (** {2 Tiny buffer implementation}
 
     These buffers are used to avoid allocating too many byte arrays when
-    processing streams and parsing requests.
+    processing streams and parsing requests. *)
-*)
 
 module Buf = Buf
 
@@ -141,37 +138,42 @@ val create :
   t
 (** Create a new webserver using UNIX abstractions.
 
-    The server will not do anything until {!run} is called on it.
+    The server will not do anything until {!run} is called on it. Before
-    Before starting the server, one can use {!add_path_handler} and
+    starting the server, one can use {!add_path_handler} and {!set_top_handler}
-    {!set_top_handler} to specify how to handle incoming requests.
+    to specify how to handle incoming requests.
 
-    @param masksigpipe if true, block the signal {!Sys.sigpipe} which otherwise
+    @param masksigpipe
-    tends to kill client threads when they try to write on broken sockets.
+      if true, block the signal {!Sys.sigpipe} which otherwise tends to kill
-    Default: [true] except when on Windows, which defaults to [false].
+      client threads when they try to write on broken sockets. Default: [true]
+      except when on Windows, which defaults to [false].
 
     @param buf_size size for buffers (since 0.11)
 
-    @param new_thread a function used to spawn a new thread to handle a
+    @param new_thread
-    new client connection. By default it is {!Thread.create} but one
+      a function used to spawn a new thread to handle a new client connection.
-    could use a thread pool instead.
+      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}
+      See for example
-      this use of moonpool}.
+      {{: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
+    @param timeout
-      write for the amount of second. Default: 0.0 which means no timeout.
+      connection is closed if the socket does not do read or write for the
-      timeout is not recommended when using proxy.
+      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
+    @param sock
-      systemd on Linux (or launchd on macOS). If passed in, this socket will be
+      an existing socket given to the server to listen on, e.g. by systemd on
-      used instead of the [addr] and [port]. If not passed in, those will be
+      Linux (or launchd on macOS). If passed in, this socket will be used
-      used. This parameter exists since 0.10.
+      instead of the [addr] and [port]. If not passed in, those will be used.
-    @param enable_logging if true and [Logs] is installed, log requests. Default true.
+      This parameter exists since 0.10.
-      This parameter exists since 0.18. Does not affect debug-level logs.
+    @param enable_logging
+      if true and [Logs] is installed, log requests. Default true. This
+      parameter exists since 0.18. Does not affect debug-level logs.
 
-    @param get_time_s obtain the current timestamp in seconds.
+    @param get_time_s
-      This parameter exists since 0.11.
+      obtain the current timestamp in seconds. This parameter exists since 0.11.
 *)

src/bin/curly.ml

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

src/camlzip/Tiny_httpd_camlzip.mli

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

src/core/IO.ml

@@ -1,12 +1,11 @@
 (** IO abstraction.
 
-    We abstract IO so we can support classic unix blocking IOs
+    We abstract IO so we can support classic unix blocking IOs with threads, and
-    with threads, and modern async IO with Eio.
+    modern async IO with Eio.
 
     {b NOTE}: experimental.
 
-    @since 0.14
+    @since 0.14 *)
-*)
 
 open Common_
 module Buf = Buf
@@ -17,7 +16,8 @@ module Output = struct
   include Iostream.Out_buf
 
   class of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t)
-    (fd : Unix.file_descr) : t =
+    (fd : Unix.file_descr) :
+    t =
     object
       inherit t_from_output ~bytes:buf.bytes ()
 
@@ -62,10 +62,10 @@ module Output = struct
   (** [chunk_encoding oc] makes a new channel that outputs its content into [oc]
       in chunk encoding form.
       @param close_rec if true, closing the result will also close [oc]
-      @param buf a buffer used to accumulate data into chunks.
+      @param buf
-        Chunks are emitted when [buf]'s size gets over a certain threshold,
+        a buffer used to accumulate data into chunks. Chunks are emitted when
-        or when [flush] is called.
+        [buf]'s size gets over a certain threshold, or when [flush] is called.
-      *)
+  *)
   let chunk_encoding ?(buf = Buf.create ()) ~close_rec (oc : #t) : t =
     (* write content of [buf] as a chunk if it's big enough.
        If [force=true] then write content of [buf] if it's simply non empty. *)
@@ -301,14 +301,14 @@ module Input = struct
     end
 
   (** new stream with maximum size [max_size].
-   @param close_rec if true, closing this will also close the input stream *)
+      @param close_rec if true, closing this will also close the input stream *)
   let limit_size_to ~close_rec ~max_size ~bytes (arg : t) : t =
     reading_exactly_ ~size:max_size ~skip_on_close:false ~bytes ~close_rec arg
 
-  (** New stream that consumes exactly [size] bytes from the input.
+  (** New stream that consumes exactly [size] bytes from the input. If fewer
-        If fewer bytes are read before [close] is called, we read and discard
+      bytes are read before [close] is called, we read and discard the remaining
-        the remaining quota of bytes before [close] returns.
+      quota of bytes before [close] returns.
-   @param close_rec if true, closing this will also close the input stream *)
+      @param close_rec if true, closing this will also close the input stream *)
   let reading_exactly ~close_rec ~size ~bytes (arg : t) : t =
     reading_exactly_ ~size ~close_rec ~skip_on_close:true ~bytes arg
 
@@ -394,16 +394,15 @@ module Writer = struct
   type t = { write: Output.t -> unit } [@@unboxed]
   (** Writer.
 
-    A writer is a push-based stream of bytes.
+      A writer is a push-based stream of bytes. Give it an output channel and it
-    Give it an output channel and it will write the bytes in it.
+      will write the bytes in it.
 
-    This is useful for responses: an http endpoint can return a writer
+      This is useful for responses: an http endpoint can return a writer as its
-    as its response's body; the writer is given access to the connection
+      response's body; the writer is given access to the connection to the
-    to the client and can write into it as if it were a regular
+      client and can write into it as if it were a regular [out_channel],
-    [out_channel], including controlling calls to [flush].
+      including controlling calls to [flush]. Tiny_httpd will convert these
-    Tiny_httpd will convert these writes into valid HTTP chunks.
+      writes into valid HTTP chunks.
-    @since 0.14
+      @since 0.14 *)
-    *)
 
   let[@inline] make ~write () : t = { write }
 
@@ -432,32 +431,32 @@ module TCP_server = struct
 
   type t = {
     endpoint: unit -> string * int;
-        (** Endpoint we listen on. This can only be called from within [serve]. *)
+        (** Endpoint we listen on. This can only be called from within [serve].
+        *)
     active_connections: unit -> int;
         (** Number of connections currently active *)
     running: unit -> bool;  (** Is the server currently running? *)
     stop: unit -> unit;
-        (** Ask the server to stop. This might not take effect immediately,
+        (** Ask the server to stop. This might not take effect immediately, and
-      and is idempotent. After this [server.running()] must return [false]. *)
+            is idempotent. After this [server.running()] must return [false]. *)
   }
   (** A running TCP server.
 
-     This contains some functions that provide information about the running
+      This contains some functions that provide information about the running
-     server, including whether it's active (as opposed to stopped), a function
+      server, including whether it's active (as opposed to stopped), a function
-     to stop it, and statistics about the number of connections. *)
+      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
+            @param after_init
-            has started. *)
+              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
+      an unspecified endpoint (most likely coming from the function returning
-      (most likely coming from the function returning this builder)
+      this builder) and returns the running server. *)
-      and returns the running server. *)
 end

src/core/buf.mli

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

src/core/gen/mkshims.ml

@@ -30,7 +30,7 @@ let () =
   let version = Scanf.sscanf Sys.ocaml_version "%d.%d.%s" (fun x y _ -> x, y) in
   print_endline
     (if version >= (4, 12) then
-      atomic_after_412
+       atomic_after_412
-    else
+     else
-      atomic_before_412);
+       atomic_before_412);
   ()

src/core/headers.ml

@@ -83,8 +83,13 @@ let parse_line_ (line : string) : _ result =
     Ok (k, v)
   with Failure msg -> Error msg
 
-let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
+let parse_ ~(buf : Buf.t) ?(max_headers = 100) ?(max_header_size = 16 * 1024)
-  let rec loop acc =
+    ?(max_total_size = 256 * 1024) (bs : IO.Input.t) : t =
+  let rec loop acc count total_size =
+    if count >= max_headers then
+      bad_reqf 431 "too many headers (max: %d)" max_headers;
+    if total_size >= max_total_size then
+      bad_reqf 431 "headers too large (max: %d bytes)" max_total_size;
     match IO.Input.read_line_using_opt ~buf bs with
     | None -> raise End_of_file
     | Some "" -> assert false
@@ -92,12 +97,15 @@ let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
     | Some line when line.[String.length line - 1] <> '\r' ->
       bad_reqf 400 "bad header line, not ended in CRLF"
     | Some line ->
+      let line_len = String.length line in
+      if line_len > max_header_size then
+        bad_reqf 431 "header too large (max: %d bytes)" max_header_size;
       let k, v =
         match parse_line_ line with
         | Ok r -> r
         | Error msg ->
           bad_reqf 400 "invalid header line: %s\nline is: %S" msg line
       in
-      loop ((k, v) :: acc)
+      loop ((k, v) :: acc) (count + 1) (total_size + line_len)
   in
-  loop []
+  loop [] 0 0

src/core/headers.mli

@@ -5,23 +5,23 @@
 type t = (string * string) list
 (** The header files of a request or response.
 
-      Neither the key nor the value can contain ['\r'] or ['\n'].
+    Neither the key nor the value can contain ['\r'] or ['\n']. See
-      See https://tools.ietf.org/html/rfc7230#section-3.2 *)
+    https://tools.ietf.org/html/rfc7230#section-3.2 *)
 
 val empty : t
 (** Empty list of headers.
-      @since 0.5 *)
+    @since 0.5 *)
 
 val get : ?f:(string -> string) -> string -> t -> string option
 (** [get k headers] looks for the header field with key [k].
-      @param f if provided, will transform the value before it is returned. *)
+    @param f if provided, will transform the value before it is returned. *)
 
 val get_exn : ?f:(string -> string) -> string -> t -> string
 (** @raise Not_found *)
 
 val set : string -> string -> t -> t
-(** [set k v headers] sets the key [k] to value [v].
+(** [set k v headers] sets the key [k] to value [v]. It erases any previous
-      It erases any previous entry for [k] *)
+    entry for [k] *)
 
 val remove : string -> t -> t
 (** Remove the key from the headers, if present. *)
@@ -34,7 +34,14 @@ val pp : Format.formatter -> t -> unit
 
 (**/*)
 
-val parse_ : buf:Buf.t -> IO.Input.t -> t
+val parse_ :
+  buf:Buf.t ->
+  ?max_headers:int ->
+  ?max_header_size:int ->
+  ?max_total_size:int ->
+  IO.Input.t ->
+  t
+
 val parse_line_ : string -> (string * string, string) result
 
 (**/*)

src/core/log.mli

@@ -5,13 +5,13 @@ val debug : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
 val error : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
 
 val setup : debug:bool -> unit -> unit
-(** Setup and enable logging. This should only ever be used in executables,
+(** Setup and enable logging. This should only ever be used in executables, not
-    not libraries.
+    libraries.
     @param debug if true, set logging to debug (otherwise info) *)
 
 val dummy : bool
 
 val fully_disable : unit -> unit
-(** Totally silence logs for tiny_httpd. With [Logs] installed this means setting
+(** Totally silence logs for tiny_httpd. With [Logs] installed this means
-    the level of the tiny_httpd source to [None]. 
+    setting the level of the tiny_httpd source to [None].
-  @since 0.18 *)
+    @since 0.18 *)

src/core/meth.mli

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

src/core/pool.mli

@@ -1,9 +1,9 @@
 (** Resource pool.
 
-    This pool is used for buffers. It can be used for other resources
+    This pool is used for buffers. It can be used for other resources but do
-    but do note that it assumes resources are still reasonably
+    note that it assumes resources are still reasonably cheap to produce and
-    cheap to produce and discard, and will never block waiting for
+    discard, and will never block waiting for a resource — it's not a good pool
-    a resource — it's not a good pool for DB connections.
+    for DB connections.
 
     @since 0.14. *)
 
@@ -14,20 +14,18 @@ val create :
   ?clear:('a -> unit) -> mk_item:(unit -> 'a) -> ?max_size:int -> unit -> 'a t
 (** Create a new pool.
     @param mk_item produce a new item in case the pool is empty
-    @param max_size maximum number of item in the pool before we start
+    @param max_size
-      dropping resources on the floor. This controls resource consumption.
+      maximum number of item in the pool before we start dropping resources on
-    @param clear a function called on items before recycling them.
+      the floor. This controls resource consumption.
- *)
+    @param clear a function called on items before recycling them. *)
 
 val with_resource : 'a t -> ('a -> 'b) -> 'b
-(** [with_resource pool f] runs [f x] with [x] a resource;
+(** [with_resource pool f] runs [f x] with [x] a resource; when [f] fails or
-    when [f] fails or returns, [x] is returned to the pool for
+    returns, [x] is returned to the pool for future reuse. *)
-    future reuse. *)
 
-(** Low level control over the pool.
+(** Low level control over the pool. This is easier to get wrong (e.g. releasing
-    This is easier to get wrong (e.g. releasing the same resource twice)
+    the same resource twice) so use with caution.
-    so use with caution.
+    @since 0.18 *)
-  @since 0.18 *)
 module Raw : sig
   val acquire : 'a t -> 'a
   val release : 'a t -> 'a -> unit

src/core/request.mli

@@ -1,7 +1,7 @@
 (** Requests
 
-    Requests are sent by a client, e.g. a web browser or cURL.
+    Requests are sent by a client, e.g. a web browser or cURL. From the point of
-    From the point of view of the server, they're inputs. *)
+    view of the server, they're inputs. *)
 
 open Common_
 
@@ -21,33 +21,32 @@ type 'body t = private {
   body: 'body;  (** Body of the request. *)
   start_time: float;
       (** Obtained via [get_time_s] in {!create}
-        @since 0.11 *)
+          @since 0.11 *)
 }
 (** A request with method, path, host, headers, and a body, sent by a client.
 
-      The body is polymorphic because the request goes through
+    The body is polymorphic because the request goes through several
-      several transformations. First it has no body, as only the request
+    transformations. First it has no body, as only the request and headers are
-      and headers are read; then it has a stream body; then the body might be
+    read; then it has a stream body; then the body might be entirely read as a
-      entirely read as a string via {!read_body_full}.
+    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 [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.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 type is a private alias
-      @since 0.11 the field [start_time] was added
+    @since 0.11 the field [start_time] was added *)
-  *)
 
 val add_meta : _ t -> 'a Hmap.key -> 'a -> unit
 (** Add metadata
- @since 0.17 *)
+    @since 0.17 *)
 
 val get_meta : _ t -> 'a Hmap.key -> 'a option
 (** Get metadata
- @since 0.17 *)
+    @since 0.17 *)
 
 val get_meta_exn : _ t -> 'a Hmap.key -> 'a
 (** Like {!get_meta} but can fail
     @raise Invalid_argument if not present
- @since 0.17 *)
+    @since 0.17 *)
 
 val pp_with :
   ?mask_header:(string -> bool) ->
@@ -71,20 +70,20 @@ val pp_with :
       which works even for stream bodies) *)
 
 val pp : Format.formatter -> string t -> unit
-(** Pretty print the request and its body. The exact format of this printing
+(** Pretty print the request and its body. The exact format of this printing is
-      is not specified. *)
+    not specified. *)
 
 val pp_ : Format.formatter -> _ t -> unit
 (** Pretty print the request without its body. The exact format of this printing
-      is not specified. *)
+    is not specified. *)
 
 val headers : _ t -> Headers.t
 (** List of headers of the request, including ["Host"]. *)
 
 val get_header : ?f:(string -> string) -> _ t -> string -> string option
 (** [get_header req h] looks up header [h] in [req]. It returns [None] if the
-      header is not present. This is case insensitive and should be used
+    header is not present. This is case insensitive and should be used rather
-      rather than looking up [h] verbatim in [headers]. *)
+    than looking up [h] verbatim in [headers]. *)
 
 val get_header_int : _ t -> string -> int option
 (** Same as {!get_header} but also performs a string to integer conversion. *)
@@ -94,22 +93,22 @@ val set_header : string -> string -> 'a t -> 'a t
 
 val remove_header : string -> 'a t -> 'a t
 (** Remove one instance of this header.
-      @since 0.17 *)
+    @since 0.17 *)
 
 val update_headers : (Headers.t -> Headers.t) -> 'a t -> 'a t
 (** Modify headers using the given function.
-      @since 0.11 *)
+    @since 0.11 *)
 
 val set_body : 'a -> _ t -> 'a t
 (** [set_body b req] returns a new query whose body is [b].
-      @since 0.11 *)
+    @since 0.11 *)
 
 val host : _ t -> string
 (** Host field of the request. It also appears in the headers. *)
 
 val client_addr : _ t -> Unix.sockaddr
 (** Client address of the request.
-      @since 0.16 *)
+    @since 0.16 *)
 
 val meth : _ t -> Meth.t
 (** Method for the request. *)
@@ -119,28 +118,26 @@ val path : _ t -> string
 
 val query : _ t -> (string * string) list
 (** Decode the query part of the {!path} field.
-      @since 0.4 *)
+    @since 0.4 *)
 
 val body : 'b t -> 'b
 (** Request body, possibly empty. *)
 
 val start_time : _ t -> float
-(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the request
+(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the
-      @since 0.11 *)
+    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
+(** Limit the body size to [max_size] bytes, or return a [413] error.
-      a [413] error.
+    @since 0.3 *)
-      @since 0.3
-  *)
 
 val read_body_full : ?bytes:bytes -> ?buf_size:int -> IO.Input.t t -> string t
 (** Read the whole body into a string. Potentially blocking.
 
     @param buf_size initial size of underlying buffer (since 0.11)
-    @param bytes the initial buffer (since 0.14)
+    @param bytes the initial buffer (since 0.14) *)
-    *)
 
 (**/**)
 

src/core/response.mli

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

src/core/response_code.ml

@@ -25,6 +25,7 @@ let descr = function
   | 411 -> "Length required"
   | 413 -> "Payload too large"
   | 417 -> "Expectation failed"
+  | 431 -> "Request Header Fields Too Large"
   | 500 -> "Internal server error"
   | 501 -> "Not implemented"
   | 503 -> "Service unavailable"

src/core/response_code.mli

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

src/core/route.mli

@@ -54,6 +54,7 @@ val to_string : _ t -> string
     @since 0.7 *)
 
 val to_url : ('a, string) t -> 'a
+
 (** [to_url route args] takes a route, and turns it into a URL path.
     @since NEXT_RELEASE *)
 

src/core/server.ml

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

src/core/server.mli

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

src/core/util.mli

@@ -1,17 +1,16 @@
 (** {1 Some utils for writing web servers}
 
-    @since 0.2
+    @since 0.2 *)
-*)
 
 val percent_encode : ?skip:(char -> bool) -> string -> string
 (** Encode the string into a valid path following
     https://tools.ietf.org/html/rfc3986#section-2.1
-    @param skip if provided, allows to preserve some characters, e.g. '/' in a path.
+    @param skip
-*)
+      if provided, allows to preserve some characters, e.g. '/' in a path. *)
 
 val percent_decode : string -> string option
-(** Inverse operation of {!percent_encode}.
+(** Inverse operation of {!percent_encode}. Can fail since some strings are not
-    Can fail since some strings are not valid percent encodings. *)
+    valid percent encodings. *)
 
 val split_query : string -> string * string
 (** Split a path between the path and the query
@@ -30,10 +29,9 @@ val get_query : string -> string
     @since 0.4 *)
 
 val parse_query : string -> ((string * string) list, string) result
-(** Parse a query as a list of ['&'] or [';'] separated [key=value] pairs.
+(** Parse a query as a list of ['&'] or [';'] separated [key=value] pairs. The
-    The order might not be preserved.
+    order might not be preserved.
-    @since 0.3
+    @since 0.3 *)
-*)
 
 val show_sockaddr : Unix.sockaddr -> string
 (** Simple printer for socket addresses.

src/html/Tiny_httpd_html.ml

@@ -1,19 +1,18 @@
 (** HTML combinators.
 
-    This module provides combinators to produce html. It doesn't enforce
+    This module provides combinators to produce html. It doesn't enforce the
-    the well-formedness of the html, unlike Tyxml, but it's simple and should
+    well-formedness of the html, unlike Tyxml, but it's simple and should be
-    be reasonably efficient.
+    reasonably efficient.
-    @since 0.12
+    @since 0.12 *)
-*)
 
 include Html_
 (** @inline *)
 
 (** Write an HTML element to this output.
-    @param top if true, add DOCTYPE at the beginning. The top element should then
+    @param top
-    be a "html" tag.
+      if true, add DOCTYPE at the beginning. The top element should then be a
-    @since 0.14
+      "html" tag.
-    *)
+    @since 0.14 *)
 let to_output ?(top = false) (self : elt) (out : #IO.Output.t) : unit =
   let out = Out.create_of_out out in
   if top then Out.add_string out "<!DOCTYPE html>\n";
@@ -22,18 +21,18 @@ let to_output ?(top = false) (self : elt) (out : #IO.Output.t) : unit =
   Out.flush out
 
 (** Convert a HTML element to a string.
-    @param top if true, add DOCTYPE at the beginning. The top element should then
+    @param top
-    be a "html" tag. *)
+      if true, add DOCTYPE at the beginning. The top element should then be a
+      "html" tag. *)
 let to_string ?top (self : elt) : string =
   let buf = Buffer.create 64 in
   let out = IO.Output.of_buffer buf in
   to_output ?top self out;
   Buffer.contents buf
 
-(** Convert a list of HTML elements to a string.
+(** Convert a list of HTML elements to a string. This is designed for fragments
-    This is designed for fragments of HTML that are to be injected inside
+    of HTML that are to be injected inside a bigger context, as it's invalid to
-    a bigger context, as it's invalid to have multiple elements at the toplevel
+    have multiple elements at the toplevel of a HTML document. *)
-    of a HTML document. *)
 let to_string_l (l : elt list) =
   let buf = Buffer.create 64 in
   let out = Out.create_of_buffer buf in
@@ -57,7 +56,7 @@ let to_writer ?top (self : elt) : IO.Writer.t =
   let write (oc : #IO.Output.t) = to_output ?top self oc in
   IO.Writer.make ~write ()
 
-(** Convert a HTML element to a stream. This might just convert
+(** Convert a HTML element to a stream. This might just convert it to a string
-    it to a string first, do not assume it to be more efficient. *)
+    first, do not assume it to be more efficient. *)
 let[@inline] to_stream (self : elt) : IO.Input.t =
   IO.Input.of_string @@ to_string self

src/moonpool-io/dune

@@ -0,0 +1,6 @@
+
+
+(library
+ (name tiny_httpd_moonpool)
+ (public_name tiny_httpd_moonpool)
+ (libraries tiny_httpd moonpool moonpool.sync moonpool.fib moonpool-io))

src/moonpool-io/io_server.ml

@@ -0,0 +1,220 @@
+open Tiny_httpd_core
+module A = Atomic
+module MIO = Moonpool_io
+module Sem = Moonpool_sync.Semaphore.Counting
+module Fd = Moonpool_io.Fd
+
+module IO_helper = struct
+  module Slice = Iostream.Slice
+
+  module Output = struct
+    include IO.Output
+
+    class of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t) (fd : Fd.t) :
+      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 MIO.Unix.write fd bs !i !len with
+            | 0 -> failwith "write failed"
+            | n ->
+              i := !i + n;
+              len := !len - n
+          done
+
+        method private close_underlying () =
+          if not !closed then (
+            closed := true;
+            if close_noerr then (
+              try MIO.Unix.close fd with _ -> ()
+            ) else
+              MIO.Unix.close fd
+          )
+      end
+  end
+
+  module Input = struct
+    include IO.Input
+
+    let of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t) (fd : Fd.t) :
+        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
+                MIO.Unix.read fd slice.bytes 0 (Bytes.length slice.bytes)
+              with
+              | n ->
+                slice.len <- n;
+                continue := false
+            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 MIO.Unix.close fd with _ -> ()
+            ) else
+              MIO.Unix.close fd
+          )
+      end
+  end
+end
+
+open struct
+  let get_addr_ (fd : Fd.t) =
+    match Unix.getsockname (Fd.unsafe_get fd) with
+    | Unix.ADDR_INET (addr, port) -> addr, port
+    | _ -> invalid_arg "httpd: address is not INET"
+
+  let shutdown_silent_ (fd : Fd.t) : unit =
+    try MIO.Unix.shutdown fd Unix.SHUTDOWN_ALL with _ -> ()
+
+  let close_silent_ (fd : Fd.t) : unit = try MIO.Unix.close fd with _ -> ()
+end
+
+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: Fd.t option;  (** Socket *)
+  new_thread: (unit -> unit) -> unit;
+  timeout: float;
+  running: bool A.t; (* TODO: use an atomic? *)
+}
+
+let to_tcp_server (self : t) : IO.TCP_server.builder =
+  {
+    IO.TCP_server.serve =
+      (fun ~after_init ~handle () : unit ->
+        let sock, should_bind =
+          match self.sock with
+          | Some s ->
+            (* Because we're getting a socket from the caller (e.g. systemd) *)
+            s, false
+          | None ->
+            let sock =
+              Unix.socket
+                (if Util.is_ipv6_str self.addr then
+                  Unix.PF_INET6
+                else
+                  Unix.PF_INET)
+                Unix.SOCK_STREAM 0
+            in
+            let fd = Fd.create sock in
+            fd, true (* Because we're creating the socket ourselves *)
+        in
+        MIO.Unix.set_nonblock sock;
+        MIO.Unix.setsockopt_optint sock Unix.SO_LINGER None;
+        if should_bind then (
+          let inet_addr = Unix.inet_addr_of_string self.addr in
+          MIO.Unix.setsockopt sock Unix.SO_REUSEADDR true;
+          MIO.Unix.bind sock (Unix.ADDR_INET (inet_addr, self.port));
+          let n_listen = 2 * self.max_connections in
+          MIO.Unix.listen sock n_listen
+        );
+
+        self.sock <- Some sock;
+
+        let tcp_server =
+          {
+            IO.TCP_server.stop = (fun () -> Atomic.set self.running false);
+            running = (fun () -> Atomic.get self.running);
+            active_connections =
+              (fun () ->
+                self.max_connections - Sem.get_value self.sem_max_connections);
+            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_ (client_sock : Fd.t) (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));
+
+          MIO.Unix.set_nonblock client_sock;
+          MIO.Unix.setsockopt client_sock Unix.TCP_NODELAY true;
+          MIO.Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout);
+          MIO.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_helper.Output.of_unix_fd
+              ~close_noerr:true ~closed ~buf:oc_buf client_sock
+          in
+          let ic =
+            IO_helper.Input.of_unix_fd ~close_noerr:true ~closed ~buf:ic_buf
+              client_sock
+          in
+          handle.handle ~client_addr ic oc
+        in
+
+        MIO.Unix.set_nonblock sock;
+        while Atomic.get self.running do
+          match MIO.Unix.accept sock with
+          | client_sock, client_addr ->
+            (* limit concurrency *)
+            Sem.acquire self.sem_max_connections;
+            self.new_thread (fun () ->
+                try
+                  handle_client_ 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 self.sem_max_connections
+                with e ->
+                  let bt = Printexc.get_raw_backtrace () in
+                  shutdown_silent_ client_sock;
+                  close_silent_ client_sock;
+                  Sem.release 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)))
+          | exception e ->
+            Log.error (fun k ->
+                k "Unix.accept raised an exception: %s" (Printexc.to_string e));
+            Atomic.set self.running false
+        done;
+
+        (* Wait for all threads to be done: this only works if all threads are done. *)
+        MIO.Unix.close sock;
+        while Sem.get_value self.sem_max_connections < self.max_connections do
+          Sem.acquire self.sem_max_connections
+        done;
+        ());
+  }

src/moonpool-io/tiny_httpd_moonpool.ml

@@ -0,0 +1,52 @@
+include Tiny_httpd
+module Fd = Io_server.Fd
+
+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 ?max_connections ?(timeout = 0.0) ?buf_size
+    ?(get_time_s = Unix.gettimeofday) ?(addr = "127.0.0.1") ?(port = 8080)
+    ?(sock : Fd.t option) ?middlewares ~(runner : Moonpool.Runner.t) () : t =
+  let new_thread f =
+    ignore (Moonpool_fib.spawn_top ~on:runner f : _ Moonpool_fib.t)
+  in
+  let max_connections = get_max_connection_ ?max_connections () in
+  let server =
+    {
+      Io_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 = Atomic.make true;
+      port;
+      sock;
+      max_connections;
+      sem_max_connections = Io_server.Sem.make max_connections;
+      timeout;
+    }
+  in
+  let tcp_server_builder = Io_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/prometheus/tiny_httpd_prometheus.mli

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

src/unix/dir.ml

@@ -43,6 +43,27 @@ let contains_dot_dot s =
     false
   with Exit -> true
 
+(* Check if string [s] starts with prefix [pre] *)
+let string_prefix ~pre s =
+  let len_pre = String.length pre in
+  String.length s >= len_pre && String.sub s 0 len_pre = pre
+
+(* Check if a path is safe (doesn't escape root directory).
+   Only needed for real filesystem access. *)
+let is_path_safe ~root_canonical ~path =
+  try
+    let full_path = Filename.concat root_canonical path in
+    let path_canonical = Unix.realpath full_path in
+    string_prefix ~pre:root_canonical path_canonical
+  with Unix.Unix_error _ ->
+    (* If realpath fails (e.g., file doesn't exist for uploads),
+       check parent directory *)
+    (try
+       let parent = Filename.dirname (Filename.concat root_canonical path) in
+       let parent_canonical = Unix.realpath parent in
+       string_prefix ~pre:root_canonical parent_canonical
+     with Unix.Unix_error _ -> false)
+
 (* Human readable size *)
 let human_size (x : int) : string =
   if x >= 1_000_000_000 then
@@ -151,9 +172,9 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt =
              [
                sub_e @@ a [ A.href ("/" // prefix // fpath) ] [ txt f ];
                (if VFS.is_directory fpath then
-                 sub_e @@ txt "[dir]"
+                  sub_e @@ txt "[dir]"
-               else
+                else
-                 sub_empty);
+                  sub_empty);
                sub_e @@ txt size;
              ])
       )
@@ -176,21 +197,21 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt =
         @@ ul' []
              [
                (if !n_hidden > 0 then
-                 sub_e
+                  sub_e
-                 @@ details' []
+                  @@ details' []
-                      [
+                       [
-                        sub_e
+                         sub_e
-                        @@ summary [] [ txtf "(%d hidden files)" !n_hidden ];
+                         @@ summary [] [ txtf "(%d hidden files)" !n_hidden ];
-                        sub_seq
+                         sub_seq
-                          (seq_of_array entries
+                           (seq_of_array entries
-                          |> Seq.filter_map (fun f ->
+                           |> Seq.filter_map (fun f ->
-                                 if is_hidden f then
+                                  if is_hidden f then
-                                   file_to_elt f
+                                    file_to_elt f
-                                 else
+                                  else
-                                   None));
+                                    None));
-                      ]
+                       ]
-               else
+                else
-                 sub_empty);
+                  sub_empty);
                sub_seq
                  (seq_of_array entries
                  |> Seq.filter_map (fun f ->
@@ -206,6 +227,17 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt =
 (* @param on_fs: if true, we assume the file exists on the FS *)
 let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
     : unit =
+  let root_canonical =
+    if on_fs then (
+      try Some (Unix.realpath top) with _ -> None
+    ) else
+      None
+  in
+  let check_path path =
+    match root_canonical with
+    | Some root -> is_path_safe ~root_canonical:root ~path
+    | None -> not (contains_dot_dot path)
+  in
   let route () =
     if prefix = "" then
       Route.rest_of_path_urlencoded
@@ -214,7 +246,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
   in
   if config.delete then
     S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req ->
-        if contains_dot_dot path then
+        if not (check_path path) then
           Response.fail_raise ~code:403 "invalid path in delete"
         else
           Response.make_string
@@ -233,7 +265,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
         | 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.Request.path ->
+        | Some _ when not (check_path req.Request.path) ->
           Error (403, "invalid path (contains '..')")
         | _ -> Ok ())
       (fun path req ->
@@ -264,7 +296,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
             | None -> Response.fail_raise ~code:403 "Cannot access file"
             | Some t -> Printf.sprintf "mtime: %.4f" t)
         in
-        if contains_dot_dot path then
+        if not (check_path path) then
           Response.fail ~code:403 "Path is forbidden"
         else if not (VFS.contains path) then
           Response.fail ~code:404 "File not found"

src/unix/dir.mli

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

src/unix/tiny_httpd_unix.ml

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

src/ws/dune

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

tests/dune

@@ -19,6 +19,27 @@
  (action
   (diff echo1.expect echo1.out)))
 
+(rule
+ (targets echo_mio1.out)
+ (deps
+  (:bin ../examples/echo_mio.exe))
+ (locks /port)
+ (enabled_if
+  (= %{system} "linux"))
+ (package tiny_httpd_moonpool)
+ (action
+  (with-stdout-to
+   %{targets}
+   (run ./echo_mio1.sh %{bin}))))
+
+(rule
+ (alias runtest)
+ (package tiny_httpd_moonpool)
+ (enabled_if
+  (= %{system} "linux"))
+ (action
+  (diff echo_mio1.expect echo_mio1.out)))
+
 (rule
  (targets sse_count.out)
  (deps

tests/echo_mio1.expect

@@ -0,0 +1,10 @@
+listening on http://127.0.0.1:8085
+test moonpool_io
+echo:
+{meth=GET; host=localhost:8085;
+ headers=[user-agent: test
+          accept: */*
+          host: localhost:8085];
+ path="/echo/?a=b&c=d"; body=""; path_components=["echo"];
+ query=["c","d";"a","b"]}
+(query: "c" = "d";"a" = "b")

tests/echo_mio1.sh

@@ -0,0 +1,12 @@
+#!/usr/bin/env sh
+
+ECHO=$1
+PORT=8085
+
+"$ECHO" -p $PORT &
+PID=$!
+sleep 0.1
+echo "test moonpool_io"
+curl -N "http://localhost:${PORT}/echo/?a=b&c=d" -H user-agent:test --max-time 5
+
+kill $PID

tests/unit/dune

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

tests/unit/t_headers.ml

@@ -0,0 +1,23 @@
+open Tiny_httpd_core
+
+(* Test that header size limits are enforced *)
+let test_header_too_large () =
+  (* Create a header that's larger than 16KB *)
+  let large_value = String.make 20000 'x' in
+  let q =
+    "GET / HTTP/1.1\r\nHost: example.com\r\nX-Large: " ^ large_value
+    ^ "\r\n\r\n"
+  in
+  let str = IO.Input.of_string q in
+  let client_addr = Unix.(ADDR_INET (inet_addr_loopback, 1024)) in
+  let buf = Buf.create () in
+  try
+    let _ =
+      Request.Private_.parse_req_start_exn ~client_addr ~buf
+        ~get_time_s:(fun _ -> 0.)
+        str
+    in
+    failwith "should have failed with 431"
+  with Tiny_httpd_core.Response.Bad_req (431, _) -> () (* expected *)
+
+let () = test_header_too_large ()

tiny_httpd.opam

@@ -17,7 +17,7 @@ depends: [
   "result"
   "hmap"
   "iostream" {>= "0.2"}
-  "ocaml" {>= "4.08"}
+  "ocaml" {>= "4.13"}
   "odoc" {with-doc}
   "logs" {with-test}
   "conf-libcurl" {with-test}

tiny_httpd_moonpool.opam

@@ -0,0 +1,35 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+version: "0.17"
+synopsis: "Moonpool+picos_stdio backend for Tiny_httpd"
+maintainer: ["c-cube"]
+authors: ["c-cube"]
+license: "MIT"
+homepage: "https://github.com/c-cube/tiny_httpd/"
+bug-reports: "https://github.com/c-cube/tiny_httpd/issues"
+depends: [
+  "dune" {>= "2.9"}
+  "seq"
+  "tiny_httpd" {= version}
+  "moonpool" {>= "0.7"}
+  "moonpool-io" {>= "0.7"}
+  "ocaml" {>= "5.0"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "--promote-install-files=false"
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+  ["dune" "install" "-p" name "--create-install-files" name]
+]
+dev-repo: "git+https://github.com/c-cube/tiny_httpd.git"