chore: bounds on eio

provides a tiny_httpd server that relies on Eio for non-blocking
sockets and for concurrency using eio fibers.

.github/workflows/gh-pages.yml

@@ -20,10 +20,10 @@ jobs:
           allow-prerelease-opam: true
 
       - name: Deps
-        run: opam install odig tiny_httpd tiny_httpd_camlzip
+        run: opam install odig tiny_httpd tiny_httpd_camlzip tiny_httpd_eio
 
       - name: Build
-        run: opam exec -- odig odoc --cache-dir=_doc/ tiny_httpd tiny_httpd_camlzip
+        run: opam exec -- odig odoc --cache-dir=_doc/ tiny_httpd tiny_httpd_camlzip tiny_httpd_eio
 
       - name: Deploy
         uses: peaceiris/actions-gh-pages@v3

.github/workflows/main.yml

@@ -38,7 +38,7 @@ jobs:
 
       - run: opam install ./tiny_httpd.opam ./tiny_httpd_camlzip.opam --deps-only --with-test
 
-      - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip
+      - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio
 
       - run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd
         if: ${{ matrix.os == 'ubuntu-latest' }}
@@ -50,4 +50,4 @@ jobs:
 
       - run: opam install logs magic-mime -y
 
-      - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip
+      - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.26.2
+version = 0.27.0
 profile=conventional
 margin=80
 if-then-else=k-r

dune-project

@@ -39,3 +39,12 @@
     (iostream-camlzip (>= 0.2.1))
     (logs :with-test)
     (odoc :with-doc)))
+
+(package
+  (name tiny_httpd_eio)
+  (synopsis "Use eio for tiny_httpd")
+  (depends
+    (tiny_httpd (= :version))
+    (eio (and (>= 1.0) (< 2.0)))
+    (logs :with-test)
+    (odoc :with-doc)))

echo_eio.sh

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

examples/dune

@@ -11,8 +11,29 @@
 (executable
  (name echo)
  (flags :standard -warn-error -a+8)
- (modules echo vfs)
- (libraries tiny_httpd logs tiny_httpd_camlzip tiny_httpd.multipart-form-data))
+ (modules echo)
+ (libraries
+  tiny_httpd
+  logs
+  echo_vfs
+  tiny_httpd_camlzip
+  tiny_httpd.multipart-form-data))
+
+(executable
+ (name echo_eio)
+ (flags :standard -warn-error -a+8)
+ (modules echo_eio)
+ (libraries
+  tiny_httpd
+  tiny_httpd_eio
+  eio
+  eio_main
+  logs
+  echo_vfs
+  trace.core
+  trace-tef
+  tiny_httpd_camlzip
+  tiny_httpd.multipart-form-data))
 
 (executable
  (name writer)
@@ -51,6 +72,12 @@
 
 ; produce an embedded FS
 
+(library
+  (name echo_vfs)
+  (modules vfs)
+  (wrapped false)
+  (libraries tiny_httpd))
+
 (rule
  (targets vfs.ml)
  (deps

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_eio.ml

@@ -0,0 +1,412 @@
+open Tiny_httpd_core
+module Trace = Trace_core
+module Log = Tiny_httpd.Log
+module MFD = Tiny_httpd_multipart_form_data
+
+let ( let@ ) = ( @@ )
+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
+
+let middleware_trace : Server.Middleware.t =
+ fun (h : Server.Middleware.handler) req ~resp ->
+  let _sp =
+    Trace.enter_manual_toplevel_span ~__FILE__ ~__LINE__ "http.handle"
+  in
+  let new_resp (r : Response.t) =
+    Trace.add_data_to_manual_span _sp [ "http.code", `Int r.code ];
+    Trace.exit_manual_span _sp;
+    resp r
+  in
+  h req ~resp:new_resp
+
+(* 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 setup_upload server : unit =
+  Server.add_route_handler_stream ~meth:`POST server
+    Route.(exact "upload" @/ return)
+    (fun req ->
+      let (`boundary boundary) =
+        match MFD.parse_content_type req.headers with
+        | Some b -> b
+        | None -> Response.fail_raise ~code:400 "no boundary found"
+      in
+
+      let st = MFD.create ~boundary req.body in
+      let tbl = Hashtbl.create 16 in
+      let cur = ref "" in
+      let cur_kind = ref "" in
+      let buf = Buffer.create 16 in
+      let rec loop () =
+        match MFD.next st with
+        | End_of_input ->
+          if !cur <> "" then
+            Hashtbl.add tbl !cur (!cur_kind, Buffer.contents buf)
+        | Part headers ->
+          if !cur <> "" then
+            Hashtbl.add tbl !cur (!cur_kind, Buffer.contents buf);
+          (match MFD.Content_disposition.parse headers with
+          | Some { kind; name = Some name; filename = _ } ->
+            cur := name;
+            cur_kind := kind;
+            Buffer.clear buf;
+            loop ()
+          | _ -> Response.fail_raise ~code:400 "content disposition missing")
+        | Read sl ->
+          Buffer.add_subbytes buf sl.bytes sl.off sl.len;
+          loop ()
+      in
+      loop ();
+
+      let open Tiny_httpd_html in
+      let data =
+        Hashtbl.fold
+          (fun name (kind, data) acc ->
+            Printf.sprintf "%S (kind: %S): %S" name kind data :: acc)
+          tbl []
+      in
+      let html =
+        body []
+          [
+            pre []
+              [ txt (Printf.sprintf "{\n%s\n}" @@ String.concat "\n" data) ];
+          ]
+      in
+      Response.make_string ~code:201 @@ Ok (to_string_top html))
+
+let () =
+  let@ () = Trace_tef.with_setup () in
+  let port_ = ref 8080 in
+  let max_conns = ref 16_000 in
+  let pool_buf_size = ref None in
+  let buf_size = ref 4096 in
+  let unix_sock = ref "" in
+  let addr = ref "127.0.0.1" in
+  Arg.parse
+    (Arg.align
+       [
+         "--port", Arg.Set_int port_, " set port";
+         "-p", Arg.Set_int port_, " set port";
+         "--unix", Arg.Set_string unix_sock, " set unix socket";
+         "--debug", Arg.Unit setup_logging, " enable debug";
+         ( "--max-buf-pool-size",
+           Arg.Int (fun i -> pool_buf_size := Some i),
+           " maximum buffer pool size" );
+         "--buf-size", Arg.Set_int buf_size, " buffer size";
+         "--max-conns", Arg.Set_int max_conns, " maximum number of connections";
+         "--addr", Arg.Set_string addr, " binding address";
+       ])
+    (fun _ -> raise (Arg.Bad ""))
+    "echo [option]*";
+
+  let@ stdenv = Eio_main.run in
+  let@ sw = Eio.Switch.run ~name:"main" in
+  let server =
+    Tiny_httpd_eio.create ~addr:!addr ~port:!port_ ~max_connections:!max_conns
+      ~buf_size:!buf_size ?max_buf_pool_size:!pool_buf_size ~stdenv ~sw ()
+  in
+
+  if Trace.enabled () then (
+    Tiny_httpd.Server.add_middleware server ~stage:(`Stage 1) middleware_trace;
+
+    (* fiber that emits metrics *)
+    Eio.Fiber.fork_daemon ~sw (fun () ->
+        while Eio.Switch.get_error sw |> Option.is_none do
+          Trace.counter_int "http.active-conns"
+            (Server.active_connections server);
+          Eio_unix.sleep 0.5
+        done;
+        `Stop_daemon)
+  );
+
+  Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16 * 1024) server;
+  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 ~meth:`HEAD server
+    Route.(exact "head" @/ return)
+    (fun _req ->
+      Response.make_void ~code:200 ~headers:[ "x-hello", "world" ] ());
+
+  (* VFS *)
+  Tiny_httpd.Dir.add_vfs server
+    ~config:
+      (Tiny_httpd.Dir.config ~download:true
+         ~dir_behavior:Tiny_httpd.Dir.Index_or_lists ())
+    ~vfs:Vfs.vfs ~prefix:"vfs";
+
+  setup_upload server;
+
+  (* 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";
+                          ];
+                      ];
+                    li []
+                      [
+                        form
+                          [
+                            A.action "/upload";
+                            A.enctype "multipart/form-data";
+                            A.target "_self";
+                            A.method_ "POST";
+                          ]
+                          [
+                            label [] [ txt "my beautiful form" ];
+                            input [ A.type_ "file"; A.name "file1" ];
+                            input [ A.type_ "file"; A.name "file2" ];
+                            input
+                              [
+                                A.type_ "text";
+                                A.name "a";
+                                A.placeholder "text A";
+                              ];
+                            input
+                              [
+                                A.type_ "text";
+                                A.name "b";
+                                A.placeholder "text B";
+                              ];
+                            input [ A.type_ "submit" ];
+                          ];
+                      ];
+                  ];
+              ];
+          ]
+      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
-       else
-         Logs.Info)
+          Logs.Debug
+        else
+          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"
-            else
-              "tock")
+               "tick"
+             else
+               "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,
-    so that several handlers can be registered.
+    IOs and threads. Basic routing based is provided for convenience, so that
+    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 server = S.create () in
+      let () =
+        let server = S.create () in
 
-  (* say hello *)
-  S.add_route_handler ~meth:`GET server
-    S.Route.(exact "hello" @/ string @/ return)
-    (fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n")));
+        (* say hello *)
+        S.add_route_handler ~meth:`GET server
+          S.Route.(exact "hello" @/ string @/ return)
+          (fun name _req ->
+            S.Response.make_string (Ok ("hello " ^ name ^ "!\n")));
 
-  (* echo request *)
-  S.add_route_handler server
-    S.Route.(exact "echo" @/ return)
-    (fun req -> S.Response.make_string
-        (Ok (Format.asprintf "echo:@ %a@." S.Request.pp req)));
+        (* echo request *)
+        S.add_route_handler server
+          S.Route.(exact "echo" @/ return)
+          (fun req ->
+            S.Response.make_string
+              (Ok (Format.asprintf "echo:@ %a@." S.Request.pp req)));
 
-  (* file upload *)
-  S.add_route_handler ~meth:`PUT server
-    S.Route.(exact "upload" @/ string_urlencoded @/ return)
-    (fun path req ->
-        try
-          let oc = open_out @@ "/tmp/" ^ path in
-          output_string oc req.S.Request.body;
-          flush oc;
-          S.Response.make_string (Ok "uploaded file")
-        with e ->
-          S.Response.fail ~code:500 "couldn't upload file: %s"
-            (Printexc.to_string e)
-      );
+        (* file upload *)
+        S.add_route_handler ~meth:`PUT server
+          S.Route.(exact "upload" @/ string_urlencoded @/ return)
+          (fun path req ->
+            try
+              let oc = open_out @@ "/tmp/" ^ path in
+              output_string oc req.S.Request.body;
+              flush oc;
+              S.Response.make_string (Ok "uploaded file")
+            with e ->
+              S.Response.fail ~code:500 "couldn't upload file: %s"
+                (Printexc.to_string e));
 
-  (* run the server *)
-  Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
-  match S.run server with
-  | Ok () -> ()
-  | Error e -> raise e
+        (* run the server *)
+        Printf.printf "listening on http://%s:%d\n%!" (S.addr server)
+          (S.port server);
+        match S.run server with
+        | Ok () -> ()
+        | Error e -> raise e
     ]}
 
     It is then possible to query it using curl:
 
     {[
-$ dune exec src/examples/echo.exe &
-listening on http://127.0.0.1:8080
+      $ dune exec src/examples/echo.exe &
+      listening on http://127.0.0.1:8080
 
-# the path "hello/name" greets you.
-$ curl -X GET http://localhost:8080/hello/quadrarotaphile
-hello quadrarotaphile!
+      # the path "hello/name" greets you.
+      $ curl -X GET http://localhost:8080/hello/quadrarotaphile
+      hello quadrarotaphile!
 
-# the path "echo" just prints the request.
-$ curl -X GET http://localhost:8080/echo --data "howdy y'all"
-echo:
-{meth=GET;
- headers=Host: localhost:8080
-         User-Agent: curl/7.66.0
-         Accept: */*
-         Content-Length: 10
-         Content-Type: application/x-www-form-urlencoded;
- path="/echo"; body="howdy y'all"}
-
-
-    ]}
-
-*)
+      # the path "echo" just prints the request.
+      $ curl -X GET http://localhost:8080/echo --data "howdy y'all"
+      echo:
+      {meth=GET;
+       headers=Host: localhost:8080
+               User-Agent: curl/7.66.0
+               Accept: */*
+               Content-Length: 10
+               Content-Type: application/x-www-form-urlencoded;
+       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.
-    Before starting the server, one can use {!add_path_handler} and
-    {!set_top_handler} to specify how to handle incoming requests.
+    The server will not do anything until {!run} is called on it. Before
+    starting the server, one can use {!add_path_handler} and {!set_top_handler}
+    to specify how to handle incoming requests.
 
-    @param masksigpipe if true, block the signal {!Sys.sigpipe} which otherwise
-    tends to kill client threads when they try to write on broken sockets.
-    Default: [true] except when on Windows, which defaults to [false].
+    @param masksigpipe
+      if true, block the signal {!Sys.sigpipe} which otherwise tends to kill
+      client threads when they try to write on broken sockets. Default: [true]
+      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
-    new client connection. By default it is {!Thread.create} but one
-    could use a thread pool instead.
-    See for example {{: https://github.com/c-cube/tiny-httpd-moonpool-bench/blob/0dcbbffb4fe34ea4ad79d46343ad0cebb69ca69f/examples/t1.ml#L31}
-      this use of moonpool}.
+    @param new_thread
+      a function used to spawn a new thread to handle a new client connection.
+      By default it is {!Thread.create} but one could use a thread pool instead.
+      See for example
+      {{:https://github.com/c-cube/tiny-httpd-moonpool-bench/blob/0dcbbffb4fe34ea4ad79d46343ad0cebb69ca69f/examples/t1.ml#L31}
+       this use of moonpool}.
 
     @param middlewares see {!add_middleware} for more details.
 
     @param max_connections maximum number of simultaneous connections.
-    @param timeout connection is closed if the socket does not do read or
-      write for the amount of second. Default: 0.0 which means no timeout.
-      timeout is not recommended when using proxy.
+    @param timeout
+      connection is closed if the socket does not do read or write for the
+      amount of second. Default: 0.0 which means no timeout. timeout is not
+      recommended when using proxy.
     @param addr address (IPv4 or IPv6) to listen on. Default ["127.0.0.1"].
     @param port to listen on. Default [8080].
-    @param sock an existing socket given to the server to listen on, e.g. by
-      systemd on Linux (or launchd on macOS). If passed in, this socket will be
-      used instead of the [addr] and [port]. If not passed in, those will be
-      used. This parameter exists since 0.10.
-    @param 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 sock
+      an existing socket given to the server to listen on, e.g. by systemd on
+      Linux (or launchd on macOS). If passed in, this socket will be used
+      instead of the [addr] and [port]. If not passed in, those will be used.
+      This parameter exists since 0.10.
+    @param 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.
-      This parameter exists since 0.11.
+    @param get_time_s
+      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 ( >>= ) :
-      type a b e. (a, e) result -> (a -> (b, e) result) -> (b, e) result =
+  let ( >>= ) : type a b e.
+      (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"; "@-" ]
-        else
-          []);
+           [ "--data-binary"; "@-" ]
+         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.
-    If installed, the middleware will compress responses' bodies
-    when they are streams or fixed-size above a given limit
-    (but it will not compress small, fixed-size bodies).
-  *)
+    This uses camlzip to provide deflate compression/decompression. If
+    installed, the middleware will compress responses' bodies when they are
+    streams or fixed-size above a given limit (but it will not compress small,
+    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
-      that has a known content-length is compressed. Stream bodies
-      are always compressed.
+    @param compress_above
+      threshold, in bytes, above which a response body that has a known
+      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
-    compressed streams
+(** Install middleware for tiny_httpd to be able to encode/decode compressed
+    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
-    with threads, and modern async IO with Eio.
+    We abstract IO so we can support classic unix blocking IOs with threads, and
+    modern async IO with Eio.
 
     {b NOTE}: experimental.
 
-    @since 0.14
-*)
+    @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.
-        Chunks are emitted when [buf]'s size gets over a certain threshold,
-        or when [flush] is called.
-      *)
+      @param buf
+        a buffer used to accumulate data into chunks. Chunks are emitted when
+        [buf]'s size gets over a certain threshold, or when [flush] is called.
+  *)
   let chunk_encoding ?(buf = Buf.create ()) ~close_rec (oc : #t) : t =
     (* write content of [buf] as a chunk if it's big enough.
        If [force=true] then write content of [buf] if it's simply non empty. *)
@@ -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.
-        If fewer bytes are read before [close] is called, we read and discard
-        the remaining quota of bytes before [close] returns.
-   @param close_rec if true, closing this will also close the input stream *)
+  (** New stream that consumes exactly [size] bytes from the input. If fewer
+      bytes are read before [close] is called, we read and discard the remaining
+      quota of bytes before [close] returns.
+      @param close_rec if true, closing this will also close the input stream *)
   let reading_exactly ~close_rec ~size ~bytes (arg : t) : t =
     reading_exactly_ ~size ~close_rec ~skip_on_close:true ~bytes arg
 
@@ -394,16 +394,15 @@ module Writer = struct
   type t = { write: Output.t -> unit } [@@unboxed]
   (** Writer.
 
-    A writer is a push-based stream of bytes.
-    Give it an output channel and it will write the bytes in it.
+      A writer is a push-based stream of bytes. Give it an output channel and it
+      will write the bytes in it.
 
-    This is useful for responses: an http endpoint can return a writer
-    as its response's body; the writer is given access to the connection
-    to the client and can write into it as if it were a regular
-    [out_channel], including controlling calls to [flush].
-    Tiny_httpd will convert these writes into valid HTTP chunks.
-    @since 0.14
-    *)
+      This is useful for responses: an http endpoint can return a writer as its
+      response's body; the writer is given access to the connection to the
+      client and can write into it as if it were a regular [out_channel],
+      including controlling calls to [flush]. Tiny_httpd will convert these
+      writes into valid HTTP chunks.
+      @since 0.14 *)
 
   let[@inline] make ~write () : t = { write }
 
@@ -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,
-      and is idempotent. After this [server.running()] must return [false]. *)
+        (** Ask the server to stop. This might not take effect immediately, and
+            is idempotent. After this [server.running()] must return [false]. *)
   }
   (** A running TCP server.
 
-     This contains some functions that provide information about the running
-     server, including whether it's active (as opposed to stopped), a function
-     to stop it, and statistics about the number of connections. *)
+      This contains some functions that provide information about the running
+      server, including whether it's active (as opposed to stopped), a function
+      to stop it, and statistics about the number of connections. *)
 
   type builder = {
     serve: after_init:(t -> unit) -> handle:conn_handler -> unit -> unit;
         (** Blocking call to listen for incoming connections and handle them.
             Uses the connection handler [handle] to handle individual client
             connections in individual threads/fibers/tasks.
-            @param after_init is called once with the server after the server
-            has started. *)
+            @param after_init
+              is called once with the server after the server has started. *)
   }
   (** A TCP server builder implementation.
 
       Calling [builder.serve ~after_init ~handle ()] starts a new TCP server on
-      an unspecified endpoint
-      (most likely coming from the function returning this builder)
-      and returns the running server. *)
+      an unspecified endpoint (most likely coming from the function returning
+      this builder) 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

@@ -26,16 +26,11 @@ let atomic_before_412 =
 
 let atomic_after_412 = {|include Atomic|}
 
-let write_file file s =
-  let oc = open_out file in
-  output_string oc s;
-  close_out oc
-
 let () =
   let version = Scanf.sscanf Sys.ocaml_version "%d.%d.%s" (fun x y _ -> x, y) in
   print_endline
     (if version >= (4, 12) then
-      atomic_after_412
-    else
-      atomic_before_412);
+       atomic_after_412
+     else
+       atomic_before_412);
   ()

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'].
-      See https://tools.ietf.org/html/rfc7230#section-3.2 *)
+    Neither the key nor the value can contain ['\r'] or ['\n']. See
+    https://tools.ietf.org/html/rfc7230#section-3.2 *)
 
 val empty : t
 (** Empty list of headers.
-      @since 0.5 *)
+    @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].
-      It erases any previous entry for [k] *)
+(** [set k v headers] sets the key [k] to value [v]. It erases any previous
+    entry for [k] *)
 
 val remove : string -> t -> t
 (** Remove the key from the headers, if present. *)

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,
-    not libraries.
+(** Setup and enable logging. This should only ever be used in executables, not
+    libraries.
     @param debug if true, set logging to debug (otherwise info) *)
 
 val dummy : bool
 
 val fully_disable : unit -> unit
-(** Totally silence logs for tiny_httpd. With [Logs] installed this means setting
-    the level of the tiny_httpd source to [None]. 
-  @since 0.18 *)
+(** Totally silence logs for tiny_httpd. With [Logs] installed this means
+    setting the level of the tiny_httpd source to [None].
+    @since 0.18 *)

src/core/meth.mli

@@ -1,10 +1,9 @@
 (** HTTP Methods *)
 
 type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
-(** A HTTP method.
-      For now we only handle a subset of these.
+(** A HTTP method. 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
-    but do note that it assumes resources are still reasonably
-    cheap to produce and discard, and will never block waiting for
-    a resource — it's not a good pool for DB connections.
+    This pool is used for buffers. It can be used for other resources but do
+    note that it assumes resources are still reasonably cheap to produce and
+    discard, and will never block waiting for a resource — it's not a good pool
+    for DB connections.
 
     @since 0.14. *)
 
@@ -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
-      dropping resources on the floor. This controls resource consumption.
-    @param clear a function called on items before recycling them.
- *)
+    @param max_size
+      maximum number of item in the pool before we start dropping resources on
+      the floor. This controls resource consumption.
+    @param clear a function called on items before recycling them. *)
 
 val with_resource : 'a t -> ('a -> 'b) -> 'b
-(** [with_resource pool f] runs [f x] with [x] a resource;
-    when [f] fails or returns, [x] is returned to the pool for
-    future reuse. *)
+(** [with_resource pool f] runs [f x] with [x] a resource; when [f] fails or
+    returns, [x] is returned to the pool for future reuse. *)
 
-(** Low level control over the pool.
-    This is easier to get wrong (e.g. releasing the same resource twice)
-    so use with caution.
-  @since 0.18 *)
+(** Low level control over the pool. This is easier to get wrong (e.g. releasing
+    the same resource twice) so use with caution.
+    @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.
-    From the point of view of the server, they're inputs. *)
+    Requests are sent by a client, e.g. a web browser or cURL. From the point of
+    view of the server, they're inputs. *)
 
 open Common_
 
@@ -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
-      several transformations. First it has no body, as only the request
-      and headers are read; then it has a stream body; then the body might be
-      entirely read as a string via {!read_body_full}.
+    The body is polymorphic because the request goes through several
+    transformations. First it has no body, as only the request and headers are
+    read; then it has a stream body; then the body might be entirely read as a
+    string via {!read_body_full}.
 
-      @since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"]
-      @since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"].
-      @since 0.11 the type is a private alias
-      @since 0.11 the field [start_time] was added
-  *)
+    @since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"]
+    @since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"].
+    @since 0.11 the type is a private alias
+    @since 0.11 the field [start_time] was added *)
 
 val add_meta : _ t -> 'a Hmap.key -> 'a -> unit
 (** Add metadata
- @since 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
-      is not specified. *)
+(** Pretty print the request and its body. The exact format of this printing is
+    not specified. *)
 
 val pp_ : Format.formatter -> _ t -> unit
 (** Pretty print the request without its body. The exact format of this printing
-      is not specified. *)
+    is not specified. *)
 
 val headers : _ t -> Headers.t
 (** List of headers of the request, including ["Host"]. *)
 
 val get_header : ?f:(string -> string) -> _ t -> string -> string option
 (** [get_header req h] looks up header [h] in [req]. It returns [None] if the
-      header is not present. This is case insensitive and should be used
-      rather than looking up [h] verbatim in [headers]. *)
+    header is not present. This is case insensitive and should be used rather
+    than looking up [h] verbatim in [headers]. *)
 
 val get_header_int : _ t -> string -> int option
 (** Same as {!get_header} but also performs a string to integer conversion. *)
@@ -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
-      @since 0.11 *)
+(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the
+    request
+    @since 0.11 *)
 
 val limit_body_size :
   max_size:int -> bytes:bytes -> IO.Input.t t -> IO.Input.t t
-(** Limit the body size to [max_size] bytes, or return
-      a [413] error.
-      @since 0.3
-  *)
+(** Limit the body size to [max_size] bytes, or return a [413] error.
+    @since 0.3 *)
 
 val read_body_full : ?bytes:bytes -> ?buf_size:int -> IO.Input.t t -> string t
 (** Read the whole body into a string. Potentially blocking.
 
     @param buf_size initial size of underlying buffer (since 0.11)
-    @param bytes the initial buffer (since 0.14)
-    *)
+    @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
-    the client to answer a {!Request.t}*)
+    Responses are what a http server, such as {!Tiny_httpd}, send back to the
+    client to answer a {!Request.t}*)
 
 type body =
   [ `String of string | `Stream of IO.Input.t | `Writer of IO.Writer.t | `Void ]
-(** Body of a response, either as a simple string,
-      or a stream of bytes, or nothing (for server-sent events notably).
+(** Body of a response, either as a simple string, or a stream of bytes, or
+    nothing (for server-sent events notably).
 
-      - [`String str] replies with a body set to this string, and a known content-length.
-      - [`Stream str] replies with a body made from this string, using chunked encoding.
-      - [`Void] replies with no body.
-      - [`Writer w] replies with a body created by the writer [w], using
-          a chunked encoding.
-        It is available since 0.14.
-  *)
+    - [`String str] replies with a body set to this string, and a known
+      content-length.
+    - [`Stream str] replies with a body made from this string, using chunked
+      encoding.
+    - [`Void] replies with no body.
+    - [`Writer w] replies with a body created by the writer [w], using a chunked
+      encoding. It is available since 0.14. *)
 
 type t = private {
   code: Response_code.t;  (** HTTP response code. See {!Response_code}. *)
   headers: Headers.t;
-      (** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *)
+      (** 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.
-      Use [""] to not send a body at all. *)
+(** Make a response from its raw components, with a string body. Use [""] to not
+    send a body at all. *)
 
 val make_raw_stream :
   ?headers:Headers.t -> code:Response_code.t -> IO.Input.t -> t
-(** Same as {!make_raw} but with a stream body. The body will be sent with
-      the chunked transfer-encoding. *)
+(** Same as {!make_raw} but with a stream body. The body will be sent with the
+    chunked transfer-encoding. *)
 
 val make_void : ?headers:Headers.t -> code:int -> unit -> t
 (** Return a response without a body at all.
-      @since 0.13 *)
+    @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 (Error (code,msg))] replies with the given error code
-        and message as body.
-  *)
+    - [make (Ok body)] replies with [200] and the body.
+    - [make (Error (code,msg))] replies with the given error code and message as
+      body. *)
 
 val make_string :
   ?headers:Headers.t ->
@@ -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.
-      Example: [fail ~code:404 "oh noes, %s not found" "waldo"].
-  *)
+(** Make the current request fail with the given code and message. Example:
+    [fail ~code:404 "oh noes, %s not found" "waldo"]. *)
 
 exception Bad_req of int * string
 (** Exception raised by {!fail_raise} with the HTTP code and body *)
 
 val fail_raise : code:int -> ('a, unit, string, 'b) format4 -> 'a
 (** Similar to {!fail} but raises an exception that exits the current handler.
-    This should not be used outside of a (path) handler.
-    Example: [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
-    @raise Bad_req always
-  *)
+    This should not be used outside of a (path) handler. Example:
+    [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
+    @raise Bad_req always *)
 
 val pp_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
-    is not specified.
-    @param mask_header function which is given each header name. If it
-      returns [true], the header's value is masked. The presence of
-      the header is still printed. Default [fun _ -> false].
-    @param headers_to_mask a list of headers masked by default.
-      Default is ["set-cookie"].
-    @param pp_body body printer
-      (default fully prints String bodies, but omits stream bodies)
+(** Pretty print the response. The exact format of this printing is not
+    specified.
+    @param mask_header
+      function which is given each header name. If it returns [true], the
+      header's value is masked. The presence of the header is still printed.
+      Default [fun _ -> false].
+    @param headers_to_mask
+      a list of headers masked by default. Default is ["set-cookie"].
+    @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.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.
-      NOTE: this is not complete (yet). *)
+(** A description of some of the error codes. NOTE: this is not complete (yet).
+*)
 
 val is_success : t -> bool
 (** [is_success code] is true iff [code] is in the [2xx] or [3xx] range.
-      @since 0.17 *)
+    @since 0.17 *)

src/core/route.ml

@@ -73,9 +73,9 @@ let rec pp_ : type a b. Buffer.t -> (a, b) t -> unit =
   | Rest { url_encoded } ->
     bpf out "<rest_of_url%s>"
       (if url_encoded then
-        "_urlencoded"
-      else
-        "")
+         "_urlencoded"
+       else
+         "")
   | Compose (Exact s, tl) -> bpf out "%s/%a" s pp_ tl
   | Compose (Int, tl) -> bpf out "<int>/%a" pp_ tl
   | Compose (String, tl) -> bpf out "<str>/%a" pp_ tl
@@ -91,3 +91,34 @@ module Private_ = struct
 end
 
 let pp out x = Format.pp_print_string out (to_string x)
+
+let rec to_url_rec : type b. Buffer.t -> (b, string) t -> b =
+ fun buf route ->
+  match route with
+  | Fire -> Buffer.contents buf
+  | Rest { url_encoded = _ } ->
+    fun str ->
+      Buffer.add_string buf str;
+      Buffer.contents buf
+  | Compose (comp, rest) ->
+    (match comp with
+    | Exact s ->
+      Buffer.add_string buf s;
+      Buffer.add_char buf '/';
+      to_url_rec buf rest
+    | Int ->
+      fun i ->
+        Printf.bprintf buf "%d/" i;
+        to_url_rec buf rest
+    | String ->
+      fun s ->
+        Printf.bprintf buf "%s/" s;
+        to_url_rec buf rest
+    | String_urlencoded ->
+      fun s ->
+        Printf.bprintf buf "%s/" (Util.percent_encode s);
+        to_url_rec buf rest)
+
+let to_url (h : ('a, string) t) : 'a =
+  let buf = Buffer.create 16 in
+  to_url_rec buf h

src/core/route.mli

@@ -1,8 +1,8 @@
 (** Routing
 
-    Basic type-safe routing of handlers based on URL paths. This is optional,
-    it is possible to only define the root handler with something like
-    {{: https://github.com/anuragsoni/routes/} Routes}.
+    Basic type-safe routing of handlers based on URL paths. This is optional, it
+    is possible to only define the root handler with something like
+    {{:https://github.com/anuragsoni/routes/} Routes}.
     @since 0.6 *)
 
 type ('a, 'b) comp
@@ -27,31 +27,33 @@ val return : ('a, 'a) t
 (** Matches the empty path. *)
 
 val rest_of_path : (string -> 'a, 'a) t
-(** Matches a string, even containing ['/']. This will match
-      the entirety of the remaining route.
-      @since 0.7 *)
+(** Matches a string, even containing ['/']. This will match the entirety of the
+    remaining route.
+    @since 0.7 *)
 
 val rest_of_path_urlencoded : (string -> 'a, 'a) t
-(** Matches a string, even containing ['/'], and URL-decode it (piecewise).
-      This will match the entirety of the remaining route.
-      @since 0.7 *)
+(** Matches a string, even containing ['/'], and URL-decode it (piecewise). This
+    will match the entirety of the remaining route.
+    @since 0.7 *)
 
 val ( @/ ) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t
-(** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"],
-      and [route] matches ["bar/…"]. *)
+(** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"], and [route]
+    matches ["bar/…"]. *)
 
 val exact_path : string -> ('a, 'b) t -> ('a, 'b) t
 (** [exact_path "foo/bar/..." r] is equivalent to
-      [exact "foo" @/ exact "bar" @/ ... @/ r]
-      @since 0.11 **)
+    [exact "foo" @/ exact "bar" @/ ... @/ r]
+    @since 0.11 **)
 
 val pp : Format.formatter -> _ t -> unit
 (** Print the route.
-      @since 0.7 *)
+    @since 0.7 *)
 
 val to_string : _ t -> string
 (** Print the route.
-      @since 0.7 *)
+    @since 0.7 *)
+
+val to_url : ('a, string) t -> 'a
 
 module Private_ : sig
   val eval : string list -> ('a, 'b) t -> 'a -> 'b option

src/core/server.ml

@@ -15,7 +15,6 @@ module Head_middleware = struct
   type t = { handle: 'a. 'a Request.t -> 'a Request.t }
 
   let trivial = { handle = Fun.id }
-  let[@inline] apply (self : t) req = self.handle req
   let[@inline] apply' req (self : t) = self.handle req
 
   let to_middleware (self : t) : Middleware.t =
@@ -50,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
-      code is [101] alongside these headers. *)
+  (** Perform the handshake and upgrade the connection. The returned code is
+      [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 *)
@@ -69,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
-    its behavior.
+    A middleware can be inserted in a handler to modify or observe 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.
-      The response can be delayed, hence the use of a continuation
-      as the [resp] parameter. *)
+  (** Handlers are functions returning a response to a request. The response can
+      be delayed, hence the use of a continuation as the [resp] parameter. *)
 
   type t = handler -> handler
   (** A middleware is a handler transformation.
 
-      It takes the existing handler [h],
-      and returns a new one which, given a query, modify it or log it
-      before passing it to [h], or fail. It can also log or modify or drop
-      the response. *)
+      It takes the existing handler [h], and returns a new one which, given a
+      query, modify it or log it before passing it to [h], or fail. It can also
+      log or modify or drop the response. *)
 
   val nil : t
   (** Trivial middleware that does nothing. *)
@@ -39,14 +34,14 @@ end
 
 (** A middleware that only considers the request's head+headers.
 
-    These middlewares are simpler than full {!Middleware.t} and
-    work in more contexts.
+    These middlewares are simpler than full {!Middleware.t} and work in more
+    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,
-    and possibly modifies it.
-    @since 0.17 *)
+  (** A handler that takes the request, without its body, and possibly modifies
+      it.
+      @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
-    based on {!Unix} and blocking IOs, but it's also possible to
-    use an OCaml 5 library using effects and non blocking IOs. *)
+    actually open a TCP server and talk to clients. The classic way is based on
+    {!Unix} and blocking IOs, but it's also possible to use an OCaml 5 library
+    using effects and non blocking IOs. *)
 module type IO_BACKEND = sig
   val init_addr : unit -> string
   (** Initial TCP address *)
@@ -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
-      on a port and handle clients. *)
+  (** TCP server builder, to create servers that can listen on a port and handle
+      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.
-    Before starting the server, one can use {!add_path_handler} and
-    {!set_top_handler} to specify how to handle incoming requests.
+    The server will not do anything until {!run} is called on it. Before
+    starting the server, one can use {!add_path_handler} and {!set_top_handler}
+    to specify how to handle incoming requests.
 
     @param buf_size size for buffers (since 0.11)
     @param 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,
-      emit logs via Logs (since 0.18).
-      Default [true].
+    @param enable_logging
+      if true and [Logs] is installed, emit logs via Logs (since 0.18). Default
+      [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
-    the port initially given if the port was [0] (meaning that the OS picks a
-    port for us). *)
+(** Port on which the server listens. Note that this might be different than the
+    port initially given if the port was [0] (meaning that the OS picks a port
+    for us). *)
 
 val active_connections : t -> int
 (** Number of currently active connections. *)
@@ -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.
-    The callback can provide a stream transformer and a new request (with
-    modified headers, typically).
-    A possible use is to handle decompression by looking for a [Transfer-Encoding]
-    header and returning a stream transformer that decompresses on the fly.
+(** Add a callback for every request. The callback can provide a stream
+    transformer and a new request (with modified headers, typically). A possible
+    use is to handle decompression by looking for a [Transfer-Encoding] header
+    and returning a stream transformer that decompresses on the fly.
 
-    @deprecated use {!add_middleware} instead
-*)
+    @deprecated use {!add_middleware} instead *)
 
 val add_encode_response_cb :
   t -> (unit Request.t -> Response.t -> Response.t option) -> unit
 [@@deprecated "use add_middleware"]
-(** Add a callback for every request/response pair.
-    Similarly to {!add_encode_response_cb} the callback can return a new
-    response, for example to compress it.
-    The callback is given the query with only its headers,
-    as well as the current response.
+(** Add a callback for every request/response pair. Similarly to
+    {!add_encode_response_cb} the callback can return a new response, for
+    example to compress it. The callback is given the query with only its
+    headers, as well as the current response.
 
-    @deprecated use {!add_middleware} instead
-*)
+    @deprecated use {!add_middleware} instead *)
 
 val add_middleware :
   stage:[ `Encoding | `Stage of int ] -> t -> Middleware.t -> unit
 (** Add a middleware to every request/response pair.
-    @param stage specify when middleware applies.
-      Encoding comes first (outermost layer), then stages in increasing order.
+    @param stage
+      specify when middleware applies. Encoding comes first (outermost layer),
+      then stages in increasing order.
     @raise Invalid_argument if stage is [`Stage n] where [n < 1]
-    @since 0.11
-*)
+    @since 0.11 *)
 
 val add_head_middleware : t -> Head_middleware.t -> unit
-(** Add a request-header only {!Head_middleware.t}.
-    This is called on requests, to modify them, and returns a new request
-    immediately.
+(** Add a request-header only {!Head_middleware.t}. This is called on requests,
+    to modify them, and returns a new request 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}.
-    If no top handler is installed, unhandled paths will return a [404] not found
+    installed via {!add_path_handler}. If no top handler is installed, unhandled
+    paths will return a [404] not found
 
-    This used to take a [string Request.t] but it now takes a [byte_stream Request.t]
-    since 0.14 . Use {!Request.read_body_full} to read the body into
-    a string if needed.
-*)
+    This used to take a [string Request.t] but it now takes a
+    [byte_stream Request.t] since 0.14 . Use {!Request.read_body_full} to read
+    the body into a string if needed. *)
 
 val add_route_handler :
   ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
@@ -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/"
-    is received.
+    calls [f "foo" 42 request] when a [request] with path "path/foo/42/" is
+    received.
 
-    Note that the handlers are called in the reverse order of their addition,
-    so the last registered handler can override previously registered ones.
+    Note that the handlers are called in the reverse order of their addition, so
+    the last registered handler can override previously registered ones.
 
-    @param meth if provided, only accept requests with the given method.
-    Typically one could react to [`GET] or [`PUT].
-    @param accept should return [Ok()] if the given request (before its body
-    is read) should be accepted, [Error (code,message)] if it's to be rejected (e.g. because
-    its content is too big, or for some permission error).
-    See the {!http_of_dir} program for an example of how to use [accept] to
-    filter uploads that are too large before the upload even starts.
-    The default always returns [Ok()], i.e. it accepts all requests.
+    @param meth
+      if provided, only accept requests with the given method. Typically one
+      could react to [`GET] or [`PUT].
+    @param accept
+      should return [Ok()] if the given request (before its body is read) should
+      be accepted, [Error (code,message)] if it's to be rejected (e.g. because
+      its content is too big, or for some permission error). See the
+      {!http_of_dir} program for an example of how to use [accept] to filter
+      uploads that are too large before the upload even starts. The default
+      always returns [Ok()], i.e. it accepts all requests.
 
-    @since 0.6
-*)
+    @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
-    is a stream of bytes that has not been read yet.
-    This is useful when one wants to stream the body directly into a parser,
-    json decoder (such as [Jsonm]) or into a file.
+(** Similar to {!add_route_handler}, but where the body of the request is a
+    stream of bytes that has not been read yet. This is useful when one wants to
+    stream the body directly into a parser, json decoder (such as [Jsonm]) or
+    into a file.
     @since 0.6 *)
 
 (** {2 Server-sent events}
@@ -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}
-    and {{: https://jvns.ca/blog/2021/01/12/day-36--server-sent-events-are-cool--and-a-fun-bug/}
-    this blog post}.
+    See
+    {{:https://html.spec.whatwg.org/multipage/server-sent-events.html} the w3c
+     page} and
+    {{:https://jvns.ca/blog/2021/01/12/day-36--server-sent-events-are-cool--and-a-fun-bug/}
+     this blog post}.
 
-    @since 0.9
-  *)
+    @since 0.9 *)
 module type SERVER_SENT_GENERATOR = sig
   val set_headers : Headers.t -> unit
-  (** Set headers of the response.
-      This is not mandatory but if used at all, it must be called before
-      any call to {!send_event} (once events are sent the response is
-      already sent too). *)
+  (** Set headers of the response. This is not mandatory but if used at all, it
+      must be called before any call to {!send_event} (once events are sent the
+      response is already sent too). *)
 
   val send_event :
     ?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
-  (** Send an event from the server.
-      If data is a multiline string, it will be sent on separate "data:" lines. *)
+  (** Send an event from the server. If data is a multiline string, it will be
+      sent on separate "data:" lines. *)
 
   val close : unit -> unit
   (** Close connection.
@@ -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
-    the client (e.g. the browser).
+(** Server-sent event generator. This generates events that are forwarded to the
+    client (e.g. the browser).
     @since 0.9 *)
 
 val add_route_server_sent_handler :
@@ -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
-    as it pleases. The connection is always closed by the client,
-    and the accepted method is always [GET].
-    This will set the header "content-type" to "text/event-stream" automatically
-    and reply with a 200 immediately.
-    See {!server_sent_generator} for more details.
+    The callback is given a generator that can be used to send events as it
+    pleases. The connection is always closed by the client, and the accepted
+    method is always [GET]. This will set the header "content-type" to
+    "text/event-stream" automatically and reply with a 200 immediately. See
+    {!server_sent_generator} for more details.
 
     This handler stays on the original thread (it is synchronous).
 
@@ -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
-      server sends a [101] response with [resp_headers];
-      or it returns [Error log_msg] if the the handshake fails, in which case
-      the connection is closed without further ado and [log_msg] is logged
-      locally (but not returned to the client). *)
+      [Ok (resp_headers, state)] in case of success, in which case the server
+      sends a [101] response with [resp_headers]; or it returns [Error log_msg]
+      if the the handshake fails, in which case the connection is closed without
+      further ado and [log_msg] is logged locally (but not returned to the
+      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
-    as {!run} might currently be waiting on IO. *)
+(** Ask the server to stop. This might not have an immediate effect as {!run}
+    might currently be waiting on IO. *)
 
 val run : ?after_init:(unit -> unit) -> t -> (unit, exn) result
-(** Run the main loop of the server, listening on a socket
-    described at the server's creation time, using [new_thread] to
-    start a thread for each new client.
+(** Run the main loop of the server, listening on a socket described at the
+    server's creation time, using [new_thread] to start a thread for each new
+    client.
 
-    This returns [Ok ()] if the server exits gracefully, or [Error e] if
-    it exits with an error.
+    This returns [Ok ()] if the server exits gracefully, or [Error e] if it
+    exits with an error.
 
     @param after_init is called after the server starts listening. since 0.13 .
 *)

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}.
-    Can fail since some strings are not valid percent encodings. *)
+(** Inverse operation of {!percent_encode}. Can fail since some strings are not
+    valid percent encodings. *)
 
 val split_query : string -> string * string
 (** Split a path between the path and the query
@@ -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.
-    The order might not be preserved.
-    @since 0.3
-*)
+(** Parse a query as a list of ['&'] or [';'] separated [key=value] pairs. The
+    order might not be preserved.
+    @since 0.3 *)
 
 val show_sockaddr : Unix.sockaddr -> string
 (** Simple printer for socket addresses.

src/eio/dune

@@ -0,0 +1,8 @@
+
+(library
+  (name tiny_httpd_eio)
+  (public_name tiny_httpd_eio)
+  (synopsis "An EIO-based backend for Tiny_httpd")
+  (flags :standard -safe-string -warn-error -a+8)
+  (libraries tiny_httpd eio eio.unix))
+

src/eio/tiny_httpd_eio.ml

@@ -0,0 +1,207 @@
+module IO = Tiny_httpd.IO
+module H = Tiny_httpd.Server
+module Pool = Tiny_httpd.Pool
+module Slice = IO.Slice
+module Log = Tiny_httpd.Log
+
+let ( let@ ) = ( @@ )
+
+type 'a with_args =
+  ?addr:string ->
+  ?port:int ->
+  ?unix_sock:string ->
+  ?max_connections:int ->
+  ?max_buf_pool_size:int ->
+  stdenv:Eio_unix.Stdenv.base ->
+  sw:Eio.Switch.t ->
+  'a
+
+let get_max_connection_ ?(max_connections = 64) () : int =
+  let max_connections = max 4 max_connections in
+  max_connections
+
+let buf_size = 16 * 1024
+
+let eio_ipaddr_to_unix (a : _ Eio.Net.Ipaddr.t) : Unix.inet_addr =
+  (* TODO: for ipv4 we really could do it faster via sprintf 🙄 *)
+  Unix.inet_addr_of_string (Format.asprintf "%a" Eio.Net.Ipaddr.pp a)
+
+let eio_sock_addr_to_unix (a : Eio.Net.Sockaddr.stream) : Unix.sockaddr =
+  match a with
+  | `Tcp (h, p) -> Unix.ADDR_INET (eio_ipaddr_to_unix h, p)
+  | `Unix s -> Unix.ADDR_UNIX s
+
+let ic_of_flow ~buf_pool:ic_pool (flow : _ Eio.Net.stream_socket) : IO.Input.t =
+  let cstruct = Pool.Raw.acquire ic_pool in
+
+  object
+    inherit Iostream.In_buf.t_from_refill ()
+
+    method private refill (sl : Slice.t) =
+      assert (sl.len = 0);
+      let cap = min (Bytes.length sl.bytes) (Cstruct.length cstruct) in
+
+      match Eio.Flow.single_read flow (Cstruct.sub cstruct 0 cap) with
+      | exception End_of_file ->
+        Log.debug (fun k -> k "read: eof");
+        ()
+      | n ->
+        Log.debug (fun k -> k "read %d bytes..." n);
+        Cstruct.blit_to_bytes cstruct 0 sl.bytes 0 n;
+        sl.off <- 0;
+        sl.len <- n
+
+    method close () =
+      Pool.Raw.release ic_pool cstruct;
+      Eio.Flow.shutdown flow `Receive
+  end
+
+let oc_of_flow ~buf_pool:oc_pool (flow : _ Eio.Net.stream_socket) : IO.Output.t
+    =
+  (* write buffer *)
+  let wbuf : Cstruct.t = Pool.Raw.acquire oc_pool in
+  let offset = ref 0 in
+
+  object (self)
+    method flush () : unit =
+      if !offset > 0 then (
+        Eio.Flow.write flow [ Cstruct.sub wbuf 0 !offset ];
+        offset := 0
+      )
+
+    method output buf i len =
+      let i = ref i in
+      let len = ref len in
+
+      while !len > 0 do
+        let available = Cstruct.length wbuf - !offset in
+        let n = min !len available in
+        Cstruct.blit_from_bytes buf !i wbuf !offset n;
+        offset := !offset + n;
+        i := !i + n;
+        len := !len - n;
+
+        if !offset = Cstruct.length wbuf then self#flush ()
+      done
+
+    method output_char c =
+      if !offset = Cstruct.length wbuf then self#flush ();
+      Cstruct.set_char wbuf !offset c;
+      incr offset;
+      if !offset = Cstruct.length wbuf then self#flush ()
+
+    method close () =
+      Pool.Raw.release oc_pool wbuf;
+      Eio.Flow.shutdown flow `Send
+  end
+
+let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size
+    ~(stdenv : Eio_unix.Stdenv.base) ~(sw : Eio.Switch.t) () :
+    (module H.IO_BACKEND) =
+  let addr, port, (sockaddr : Eio.Net.Sockaddr.stream) =
+    match addr, port, unix_sock with
+    | _, _, Some s -> Printf.sprintf "unix:%s" s, 0, `Unix s
+    | addr, port, None ->
+      let addr = Option.value ~default:"127.0.0.1" addr in
+      let sockaddr, port =
+        match Eio.Net.getaddrinfo stdenv#net addr, port with
+        | `Tcp (h, _) :: _, None ->
+          let p = 8080 in
+          `Tcp (h, p), p
+        | `Tcp (h, _) :: _, Some p -> `Tcp (h, p), p
+        | _ ->
+          failwith @@ Printf.sprintf "Could not parse TCP address from %S" addr
+      in
+      addr, port, sockaddr
+  in
+
+  let module M = struct
+    let init_addr () = addr
+    let init_port () = port
+    let get_time_s () = Unix.gettimeofday ()
+    let max_connections = get_max_connection_ ?max_connections ()
+
+    let pool_size =
+      match max_buf_pool_size with
+      | Some n -> n
+      | None -> min 4096 (max_connections * 2)
+
+    let cstruct_pool =
+      Pool.create ~max_size:max_connections
+        ~mk_item:(fun () -> Cstruct.create buf_size)
+        ()
+
+    let tcp_server () : IO.TCP_server.builder =
+      {
+        IO.TCP_server.serve =
+          (fun ~after_init ~handle () : unit ->
+            let running = Atomic.make true in
+            let active_conns = Atomic.make 0 in
+
+            Eio.Switch.on_release sw (fun () -> Atomic.set running false);
+            let net = Eio.Stdenv.net stdenv in
+
+            (* main server socket *)
+            let sock =
+              let backlog = max_connections in
+              Eio.Net.listen ~reuse_addr:true ~reuse_port:true ~backlog ~sw net
+                sockaddr
+            in
+
+            let tcp_server : IO.TCP_server.t =
+              {
+                running = (fun () -> Atomic.get running);
+                stop =
+                  (fun () ->
+                    Atomic.set running false;
+                    Eio.Switch.fail sw Exit);
+                endpoint =
+                  (fun () ->
+                    (* TODO: find the real port *)
+                    addr, port);
+                active_connections = (fun () -> Atomic.get active_conns);
+              }
+            in
+
+            after_init tcp_server;
+
+            while Atomic.get running do
+              Eio.Net.accept_fork ~sw
+                ~on_error:(fun exn ->
+                  Log.error (fun k ->
+                      k "error in client handler: %s" (Printexc.to_string exn)))
+                sock
+                (fun flow client_addr ->
+                  Atomic.incr active_conns;
+                  let@ () =
+                    Fun.protect ~finally:(fun () ->
+                        Log.debug (fun k ->
+                            k "Tiny_httpd_eio: client handler returned");
+                        Atomic.decr active_conns)
+                  in
+                  let ic = ic_of_flow ~buf_pool:cstruct_pool flow in
+                  let oc = oc_of_flow ~buf_pool:cstruct_pool flow in
+
+                  Log.debug (fun k ->
+                      k "handling client on %a…" Eio.Net.Sockaddr.pp client_addr);
+                  let client_addr_unix = eio_sock_addr_to_unix client_addr in
+                  try handle.handle ~client_addr:client_addr_unix ic oc
+                  with exn ->
+                    let bt = Printexc.get_raw_backtrace () in
+                    Log.error (fun k ->
+                        k "Client handler for %a failed with %s\n%s"
+                          Eio.Net.Sockaddr.pp client_addr
+                          (Printexc.to_string exn)
+                          (Printexc.raw_backtrace_to_string bt)))
+            done);
+      }
+  end in
+  (module M)
+
+let create ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size ~stdenv
+    ~sw ?buf_size ?middlewares () : H.t =
+  let backend =
+    io_backend ?addr ?port ?unix_sock ?max_buf_pool_size ?max_connections
+      ~stdenv ~sw ()
+  in
+  H.create_from ?buf_size ?middlewares ~backend ()

src/eio/tiny_httpd_eio.mli

@@ -0,0 +1,31 @@
+(** Tiny httpd EIO backend.
+
+    This replaces the threads + Unix blocking syscalls of {!Tiny_httpd_server}
+    with an Eio-based cooperative system.
+
+    {b NOTE}: this is very experimental and will absolutely change over time,
+    especially since Eio itself is also subject to change.
+    @since NEXT_RELEASE *)
+
+(* TODO: pass in a switch *)
+
+type 'a with_args =
+  ?addr:string ->
+  ?port:int ->
+  ?unix_sock:string ->
+  ?max_connections:int ->
+  ?max_buf_pool_size:int ->
+  stdenv:Eio_unix.Stdenv.base ->
+  sw:Eio.Switch.t ->
+  'a
+
+val io_backend : (unit -> (module Tiny_httpd.Server.IO_BACKEND)) with_args
+(** Create a server *)
+
+val create :
+  (?buf_size:int ->
+  ?middlewares:([ `Encoding | `Stage of int ] * Tiny_httpd.Middleware.t) list ->
+  unit ->
+  Tiny_httpd.Server.t)
+  with_args
+(** Create a server *)

src/html/Tiny_httpd_html.ml

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

src/html/gen/gentags.ml

@@ -1,7 +1,6 @@
 (* adapted from https://github.com/sindresorhus/html-tags (MIT licensed) *)
 
 let pf = Printf.printf
-let spf = Printf.sprintf
 
 let void =
   [

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
- for counters, gauges, and histogram, and endpoints to expose
- them for {{: https://prometheus.io/} Prometheus} to scrape them.
+    This sub-library [tiny_httpd.prometheus] provides definitions for counters,
+    gauges, and histogram, and endpoints to expose them for
+    {{: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
-      [emit buf registry] is called (before the metrics start being emitted). This
-      is useful to update some metrics on demand. *)
+  (** [on_will_emit registry f] calls [f()] every time [emit buf registry] is
+      called (before the metrics start being emitted). This is useful to update
+      some metrics on demand. *)
 
   val emit : Buffer.t -> t -> unit
-  (** Write metrics into the given buffer. The buffer will be
-      cleared first thing. *)
+  (** Write metrics into the given buffer. The buffer will be cleared first
+      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
-      value this does nothing *)
+  (** Increment to the given number. If it's lower than the current value this
+      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,
-    adds them to the registry, and uses {!Registry.on_will_emit}
-    to {!update} the metrics every time the registry is polled. *)
+  (** [create_and_update_before_emit reg] creates new GC metrics, adds them to
+      the registry, and uses {!Registry.on_will_emit} to {!update} the metrics
+      every time the registry is polled. *)
 end

src/unix/dir.ml

@@ -151,9 +151,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]"
-               else
-                 sub_empty);
+                  sub_e @@ txt "[dir]"
+                else
+                  sub_empty);
                sub_e @@ txt size;
              ])
       )
@@ -176,21 +176,21 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt =
         @@ ul' []
              [
                (if !n_hidden > 0 then
-                 sub_e
-                 @@ details' []
-                      [
-                        sub_e
-                        @@ summary [] [ txtf "(%d hidden files)" !n_hidden ];
-                        sub_seq
-                          (seq_of_array entries
-                          |> Seq.filter_map (fun f ->
-                                 if is_hidden f then
-                                   file_to_elt f
-                                 else
-                                   None));
-                      ]
-               else
-                 sub_empty);
+                  sub_e
+                  @@ details' []
+                       [
+                         sub_e
+                         @@ summary [] [ txtf "(%d hidden files)" !n_hidden ];
+                         sub_seq
+                           (seq_of_array entries
+                           |> Seq.filter_map (fun f ->
+                                  if is_hidden f then
+                                    file_to_elt f
+                                  else
+                                    None));
+                       ]
+                else
+                  sub_empty);
                sub_seq
                  (seq_of_array entries
                  |> Seq.filter_map (fun f ->

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.
-    It exposes a directory (and its subdirectories), with the optional ability
-    to delete or upload files.
+    This module provides the same functionality as the "http_of_dir" tool. It
+    exposes a directory (and its subdirectories), with the optional ability to
+    delete or upload files.
 
     @since 0.11 *)
 
 (** behavior of static directory.
 
-    This controls what happens when the user requests the path to
-    a directory rather than a file. *)
+    This controls what happens when the user requests the path to a directory
+    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.
-      This is useful for tilde ("~") directories and other per-user behavior,
-      but be mindful of security implications *)
+      (** Redirect to index.html if present and lists content otherwise. This is
+          useful for tilde ("~") directories and other per-user behavior, but be
+          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.
-    Use {!default_config} or {!config} instead. *)
+(** Type used to prevent users from building a config directly. Use
+    {!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
-      uploaded files. *)
+      (** If {!upload} is true, this is the maximum size in bytes for uploaded
+          files. *)
   _rest: hidden;  (** Just ignore this field. *)
 }
-(** configuration for static file handlers. This might get
-    more fields over time. *)
+(** configuration for static file handlers. This might get more fields over
+    time. *)
 
 val default_config : unit -> config
-(** default configuration: [
-  { download=true
-  ; dir_behavior=Forbidden
-  ; delete=false
-  ; upload=false
-  ; max_upload_size = 10 * 1024 * 1024
-  }] *)
+(** default configuration:
+    [ { download=true ; dir_behavior=Forbidden ; 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
-    [server] to serve static files in [dir] when url starts with [prefix],
-    using the given configuration [config]. *)
+(** [add_dirpath ~config ~dir ~prefix server] adds route handle to the [server]
+    to serve static files in [dir] when url starts with [prefix], using the
+    given configuration [config]. *)
 
 (** 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
-      or directory inside [vfs]. *)
+  (** [file_exists vfs path] returns [true] if [path] points to a file or
+      directory inside [vfs]. *)
 
   val list_dir : string -> string array
-  (** List directory. This only returns basenames, the files need
-      to be put in the directory path using {!Filename.concat}. *)
+  (** List directory. This only returns basenames, the files need to be put in
+      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
-    disk.
-    @since 0.12
-*)
+(** [vfs_of_dir dir] makes a virtual file system that reads from the disk.
+    @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.
-    This is useful in combination with the "tiny-httpd-mkfs" tool,
-    which embeds the files it's given into a OCaml module.
+(** An embedded file system, as a list of files with (relative) paths. This is
+    useful in combination with the "tiny-httpd-mkfs" tool, which embeds the
+    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
-      make a directory out of an existing path that is a file. *)
+      @raise Invalid_argument
+        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
-                  else
-                    Unix.PF_INET)
+                     Unix.PF_INET6
+                   else
+                     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))
- (action (with-stdout-to %{target} (echo "-O%{env:BUILD_TINY_HTTPD_OPTLEVEL=2}"))))
+ (deps
+  (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))
- (action (with-stdout-to %{target} (echo ""))))
+ (deps
+  (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))

src/ws/tiny_httpd_ws.ml

@@ -187,8 +187,8 @@ module Reader = struct
   type state =
     | Begin  (** At the beginning of a frame *)
     | Reading_frame of { mutable remaining_bytes: int; mutable num_read: int }
-        (** Currently reading the payload of a frame with [remaining_bytes]
-        left to read from the underlying [ic] *)
+        (** Currently reading the payload of a frame with [remaining_bytes] left
+            to read from the underlying [ic] *)
     | Close
 
   type t = {
@@ -266,7 +266,7 @@ module Reader = struct
   external apply_masking_ :
     key:bytes -> key_offset:int -> buf:bytes -> int -> int -> unit
     = "tiny_httpd_ws_apply_masking"
-    [@@noalloc]
+  [@@noalloc]
   (** Apply masking to the parsed data *)
 
   let[@inline] apply_masking ~mask_key ~mask_offset (buf : bytes) off len : unit
@@ -414,7 +414,8 @@ let upgrade ic oc : _ * _ =
   in
   ws_ic, ws_oc
 
-(** Turn a regular connection handler (provided by the user) into a websocket upgrade handler *)
+(** Turn a regular connection handler (provided by the user) into a websocket
+    upgrade handler *)
 module Make_upgrade_handler (X : sig
   val accept_ws_protocol : string -> bool
   val handler : handler

src/ws/tiny_httpd_ws.mli

@@ -1,8 +1,7 @@
 (** Websockets for Tiny_httpd.
 
-    This sub-library ([tiny_httpd.ws]) exports a small implementation
-    for a websocket server. It has no additional dependencies.
-    *)
+    This sub-library ([tiny_httpd.ws]) exports a small implementation for a
+    websocket server. It has no additional dependencies. *)
 
 type handler = unit Request.t -> IO.Input.t -> IO.Output.t -> unit
 (** Websocket handler *)
@@ -11,8 +10,8 @@ val upgrade : IO.Input.t -> IO.Output.t -> IO.Input.t * IO.Output.t
 (** Upgrade a byte stream to the websocket framing protocol. *)
 
 exception Close_connection
-(** Exception that can be raised from IOs inside the handler,
-    when the connection is closed from underneath. *)
+(** Exception that can be raised from IOs inside the handler, when the
+    connection is closed from underneath. *)
 
 val add_route_handler :
   ?accept:(unit Request.t -> (unit, int * string) result) ->
@@ -23,8 +22,9 @@ val add_route_handler :
   handler ->
   unit
 (** Add a route handler for a websocket endpoint.
-    @param accept_ws_protocol decides whether this endpoint accepts the websocket protocol
-    sent by the client. Default accepts everything. *)
+    @param accept_ws_protocol
+      decides whether this endpoint accepts the websocket protocol sent by the
+      client. Default accepts everything. *)
 
 (**/**)
 

src/ws/tiny_httpd_ws_stubs.c

@@ -8,7 +8,7 @@ CAMLprim value tiny_httpd_ws_apply_masking(value _mask_key, value _mask_offset,
   CAMLparam5(_mask_key, _mask_offset, _buf, _offset, _len);
 
   char const *mask_key = String_val(_mask_key);
-  char *buf = Bytes_val(_buf);
+  unsigned char *buf = Bytes_val(_buf);
   intnat mask_offset = Int_val(_mask_offset);
   intnat offset = Int_val(_offset);
   intnat len = Int_val(_len);

tiny_httpd_eio.opam

@@ -0,0 +1,31 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+version: "0.19"
+synopsis: "Use eio 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" {>= "3.2"}
+  "tiny_httpd" {= version}
+  "eio" {>= "1.0" & < "2.0"}
+  "logs" {with-test}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/c-cube/tiny_httpd.git"