doc

can be replaced with a proper cooperative lock

.github/workflows/gh-pages.yml

@@ -3,7 +3,7 @@ name: github pages
 on:
   push:
     branches:
-      - master
+      - main
 
 jobs:
   deploy:
@@ -13,13 +13,24 @@ jobs:
         uses: actions/checkout@v3
 
       - name: Use OCaml
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
-          ocaml-compiler: 5.0
+          ocaml-compiler: 5.03.x
           dune-cache: true
+          allow-prerelease-opam: true
 
-      - name: Deploy odoc to GitHub Pages
-        uses: ocaml/setup-ocaml/deploy-doc@v2
+      - name: Deps
+        run: opam install odig tiny_httpd tiny_httpd_camlzip
+
+      - name: Build
+        run: opam exec -- odig odoc --cache-dir=_doc/ tiny_httpd tiny_httpd_camlzip
+
+      - name: Deploy
+        uses: peaceiris/actions-gh-pages@v3
         with:
-          destination-dir: dev
-          enable-jekyll: true
+          github_token: ${{ secrets.GITHUB_TOKEN }}
+          publish_dir: ./_doc/html
+          destination_dir: .
+          enable_jekyll: false
+            #keep_files: true
+

.github/workflows/main.yml

@@ -3,9 +3,8 @@ name: build
 on:
   pull_request:
   push:
-  schedule:
-    # Prime the caches every Monday
-    - cron: 0 1 * * MON
+    branches:
+      - main
 
 jobs:
   build:
@@ -17,8 +16,9 @@ jobs:
             #- macos-latest
             #- windows-latest
         ocaml-compiler:
-          - 4.05
-          - 4.14
+          - 4.08.x
+          - 4.14.x
+          - 5.03.x
 
     runs-on: ${{ matrix.os }}
 
@@ -26,13 +26,14 @@ jobs:
       - name: Checkout code
         uses: actions/checkout@v3
 
+      - run: sudo apt-get update
+        if: ${{ matrix.os == 'ubuntu-latest' }}
+
       - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
-          opam-local-packages: |
-            ./tiny_httpd.opam
-            ./tiny_httpd_camlzip.opam
+          allow-prerelease-opam: true
           opam-depext-flags: --with-test
 
       - run: opam install ./tiny_httpd.opam ./tiny_httpd_camlzip.opam --deps-only --with-test
@@ -47,3 +48,6 @@ jobs:
       - run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd_camlzip
         if: ${{ matrix.os == 'ubuntu-latest' }}
 
+      - run: opam install logs magic-mime -y
+
+      - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip

.github/workflows/main5.yml

@@ -1,45 +0,0 @@
-name: build (ocaml 5)
-
-on:
-  pull_request:
-  push:
-  schedule:
-    # Prime the caches every Monday
-    - cron: 0 1 * * MON
-
-jobs:
-  build:
-    strategy:
-      fail-fast: true
-      matrix:
-        os:
-          - ubuntu-latest
-            #- macos-latest
-            #- windows-latest
-        ocaml-compiler:
-          - 5.0.x
-
-    runs-on: ${{ matrix.os }}
-
-    steps:
-      - name: Checkout code
-        uses: actions/checkout@v3
-
-      - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v2
-        with:
-          ocaml-compiler: ${{ matrix.ocaml-compiler }}
-          opam-depext-flags: --with-test
-
-      - run: opam install . --deps-only --with-test
-
-      - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip
-
-      - run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd
-        if: ${{ matrix.os == 'ubuntu-latest' }}
-
-      - run: opam install tiny_httpd
-
-      - run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd_camlzip
-        if: ${{ matrix.os == 'ubuntu-latest' }}
-

.ocamlformat

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

CHANGES.md

@@ -1,4 +1,58 @@
 
+## 0.19
+
+- feat(headers): `set` will not reallocate whole list if not needed
+- feat(headers): use case insensitive comparison
+- fix(response): do not override "content-length" in raw response
+- feat pool: expose `acquire/release` for advanced uses
+
+## 0.18
+
+- feat: add ?head_middlewares to `create`
+- add content-type header for prometheus endpoint
+- new flag ?enable_logging to disable regular logs (not debug)
+- new sublibrary to deal with multipart-form-data
+- feat response: add `pp_with`; have `pp` hide set-cookie headers
+
+- fix percent encoding for < 0x10 chars
+- Processing to fix incompatible -O and gcc flags
+- fix: make check for 'Connection: Upgrade' header case-insensitive
+
+## 0.17
+
+- add optional middlewares to tiny_httpd_ws
+- add `Head_middleware.trivial`
+- add `Head_middleware.t`; accept it for SSE/websocket
+- add `Request.pp_with` which is a customizable printer
+- expose `Response.Bad_req`
+- use `iostream` for IOs
+- add a `hmap`-typed field to requests, to carry request specific data
+    across middlewares
+- http_of_dir: ability to setup socket timeout
+- add `tiny_httpd.ws`, a websocket library
+- add `Response_code.is_success`
+
+- fix: No setting of sigprocmask on Windows
+- fix: give the correct code+error if protocol upgrade fails
+- remove potentially security-leaking debug line
+- fix: avoid collisions in `Mime_` private module
+- fix middlewares: merge-sort per-request middleares and global ones
+- fix tiny_httpd dir: handle html files
+
+- perf: optim in read_line
+- perf: remove some uses of scanf in parsing
+
+- require iostream-camlzip >= 0.2.1
+- add optional dependency on `logs`
+- logs is a testdep for tiny_httpd_camlzip
+
+## 0.16
+
+- feat: add `Request.client_addr` accessor
+- feat: add `tiny_httpd.prometheus`, a simple sub-library
+    to expose [prometheus](https://prometheus.io) metrics over HTTP.
+- feat: add optional dependency on `logs`
+
 ## 0.15
 
 - fix: do not block in `accept`, enabling more graceful shutdown

Makefile

@@ -9,9 +9,18 @@ build:
 test:
 	@dune runtest --no-buffer --force $(OPTS)
 
+test-autopromote:
+	@dune runtest --no-buffer --force $(OPTS) --auto-promote
+
 clean:
 	@dune clean
 
+format:
+	@dune build @fmt --auto-promote
+
+format-check:
+	@dune build @fmt --ignore-promoted-rules
+
 doc:
 	@dune build @doc
 

dune-project

@@ -1,10 +1,10 @@
-(lang dune 2.9)
+(lang dune 3.2)
 (name tiny_httpd)
 (generate_opam_files true)
 
 (authors c-cube)
 (maintainers c-cube)
-(version 0.15)
+(version 0.19)
 (source (github c-cube/tiny_httpd))
 (homepage https://github.com/c-cube/tiny_httpd/)
 (license MIT)
@@ -13,12 +13,19 @@
   (name tiny_httpd)
   (synopsis "Minimal HTTP server using threads")
   (tags (http thread server tiny_httpd http_of_dir simplehttpserver))
+  (depopts
+    logs
+    magic-mime
+    (mtime (>= 2.0)))
   (depends
     seq
     base-threads
     result
-    (ocaml (>= 4.05))
+    hmap
+    (iostream (>= 0.2))
+    (ocaml (>= 4.08))
     (odoc :with-doc)
+    (logs :with-test)
     (conf-libcurl :with-test)
     (ptime :with-test)
     (qcheck-core (and (>= 0.9) :with-test))))
@@ -29,4 +36,6 @@
   (depends
     (tiny_httpd (= :version))
     (camlzip (>= 1.06))
+    (iostream-camlzip (>= 0.2.1))
+    (logs :with-test)
     (odoc :with-doc)))

echo_ws.sh

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

examples/dune

@@ -1,7 +1,7 @@
 (executable
  (name sse_server)
  (modules sse_server)
- (libraries tiny_httpd unix ptime ptime.clock.os))
+ (libraries tiny_httpd logs unix ptime ptime.clock.os))
 
 (executable
  (name sse_client)
@@ -12,13 +12,19 @@
  (name echo)
  (flags :standard -warn-error -a+8)
  (modules echo vfs)
- (libraries tiny_httpd tiny_httpd_camlzip))
+ (libraries tiny_httpd logs tiny_httpd_camlzip tiny_httpd.multipart-form-data))
 
 (executable
  (name writer)
  (flags :standard -warn-error -a+8)
  (modules writer)
- (libraries tiny_httpd))
+ (libraries tiny_httpd logs))
+
+(executable
+ (name echo_ws)
+ (flags :standard -warn-error -a+8)
+ (modules echo_ws)
+ (libraries tiny_httpd tiny_httpd.ws logs))
 
 (rule
  (targets test_output.txt)

examples/echo.ml

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

examples/echo_ws.ml

@@ -0,0 +1,65 @@
+module S = Tiny_httpd
+open Tiny_httpd_core
+
+let setup_logging ~debug () =
+  Logs.set_reporter @@ Logs.format_reporter ();
+  Logs.set_level ~all:true
+  @@ Some
+       (if debug then
+         Logs.Debug
+       else
+         Logs.Info)
+
+let handle_ws (req : unit Request.t) ic oc =
+  Log.info (fun k ->
+      k "new client connection from %s" (Util.show_sockaddr req.client_addr));
+
+  let (_ : Thread.t) =
+    Thread.create
+      (fun () ->
+        while true do
+          Thread.delay 3.;
+          IO.Output.output_string oc "(special ping!)";
+          IO.Output.flush oc
+        done)
+      ()
+  in
+
+  let buf = Bytes.create 32 in
+  let continue = ref true in
+  while !continue do
+    let n = IO.Input.input ic buf 0 (Bytes.length buf) in
+    Log.debug (fun k ->
+        k "echo %d bytes from websocket: %S" n (Bytes.sub_string buf 0 n));
+
+    if n = 0 then continue := false;
+    IO.Output.output oc buf 0 n;
+    IO.Output.flush oc
+  done;
+  Log.info (fun k -> k "client exiting")
+
+let () =
+  let port_ = ref 8080 in
+  let j = ref 32 in
+  let debug = ref false in
+  Arg.parse
+    (Arg.align
+       [
+         "--port", Arg.Set_int port_, " set port";
+         "-p", Arg.Set_int port_, " set port";
+         "--debug", Arg.Set debug, " enable debug";
+         "-j", Arg.Set_int j, " maximum number of connections";
+       ])
+    (fun _ -> raise (Arg.Bad ""))
+    "echo [option]*";
+  setup_logging ~debug:!debug ();
+
+  let server = S.create ~port:!port_ ~max_connections:!j () in
+  Tiny_httpd_ws.add_route_handler server
+    Route.(exact "echo" @/ return)
+    handle_ws;
+
+  Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
+  match S.run server with
+  | Ok () -> ()
+  | Error e -> raise e

examples/sse_demo.html

@@ -0,0 +1,21 @@
+
+<!-- to be used with sse_server -p 8087 -->
+
+<html>
+<head>
+  <script src="https://unpkg.com/htmx.org@1.7.0"></script>
+
+  <script>
+    htmx.createEventSource = (url) => {
+		return new EventSource(url, {withCredentials:false});
+	}
+
+  </script>
+
+</head>
+<body hx-trigger="onload" hx-sse="connect:http://localhost:8087/clock">
+  <p>time:</p>
+  <div hx-sse="swap:tick" hx-swap="innerHtml"> </div>
+  <!-- <div hx-trigger="sse:tick" hx-get="/news"></div> -->
+</body>
+</html>

examples/sse_server.ml

@@ -1,6 +1,6 @@
 (* serves some streams of events *)
 
-module S = Tiny_httpd
+open Tiny_httpd_core
 
 let port = ref 8080
 
@@ -9,11 +9,11 @@ let () =
     (Arg.align
        [
          "-p", Arg.Set_int port, " port to listen on";
-         "--debug", Arg.Bool S._enable_debug, " toggle debug";
+         "--debug", Arg.Unit (Log.setup ~debug:true), " enable debug";
        ])
     (fun _ -> ())
     "sse_clock [opt*]";
-  let server = S.create ~port:!port () in
+  let server = Tiny_httpd.create ~port:!port () in
 
   let extra_headers =
     [
@@ -23,15 +23,15 @@ let () =
   in
 
   (* tick/tock goes the clock *)
-  S.add_route_server_sent_handler server
-    S.Route.(exact "clock" @/ return)
-    (fun _req (module EV : S.SERVER_SENT_GENERATOR) ->
-      S._debug (fun k -> k "new connection");
+  Server.add_route_server_sent_handler server
+    Route.(exact "clock" @/ return)
+    (fun _req (module EV : Server.SERVER_SENT_GENERATOR) ->
+      Log.debug (fun k -> k "new SSE connection");
       EV.set_headers extra_headers;
       let tick = ref true in
       while true do
         let now = Ptime_clock.now () in
-        S._debug (fun k ->
+        Log.debug (fun k ->
             k "send clock ev %s" (Format.asprintf "%a" Ptime.pp now));
         EV.send_event
           ~event:
@@ -46,26 +46,26 @@ let () =
       done);
 
   (* just count *)
-  S.add_route_server_sent_handler server
-    S.Route.(exact "count" @/ return)
-    (fun _req (module EV : S.SERVER_SENT_GENERATOR) ->
+  Server.add_route_server_sent_handler server
+    Route.(exact "count" @/ return)
+    (fun _req (module EV : Server.SERVER_SENT_GENERATOR) ->
       let n = ref 0 in
       while true do
         EV.send_event ~data:(string_of_int !n) ();
         incr n;
         Unix.sleepf 0.1
       done);
-  S.add_route_server_sent_handler server
-    S.Route.(exact "count" @/ int @/ return)
-    (fun n _req (module EV : S.SERVER_SENT_GENERATOR) ->
+  Server.add_route_server_sent_handler server
+    Route.(exact "count" @/ int @/ return)
+    (fun n _req (module EV : Server.SERVER_SENT_GENERATOR) ->
       for i = 0 to n do
         EV.send_event ~data:(string_of_int i) ();
         Unix.sleepf 0.1
       done;
       EV.close ());
 
-  Printf.printf "listening on http://localhost:%d/\n%!" (S.port server);
-  match S.run server with
+  Printf.printf "listening on http://localhost:%d/\n%!" (Server.port server);
+  match Server.run server with
   | Ok () -> ()
   | Error e ->
     Printf.eprintf "error: %s\n%!" (Printexc.to_string e);

examples/writer.ml

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

examples/ws_demo.html

@@ -0,0 +1,25 @@
+<!-- to be used with echo_ws -p 8085 -->
+<html>
+
+<head>
+  <script>
+
+    console.log('hello')
+
+    const ws = new WebSocket('ws://localhost:8085/echo');
+    ws.onmessage = (msg) => console.log(`received: ${msg}`);
+
+    let count = 0;
+    setInterval(() => {
+      const msg = `hello ${count++}`;
+      console.log(`send ${msg}`);
+      ws.send(msg);
+    }, 2000);
+  </script>
+</head>
+
+<body>
+  open console!
+</body>
+
+</html>

http_of_dir.sh

@@ -1,2 +1,3 @@
 #!/bin/sh
-exec dune exec ./src/bin/http_of_dir.exe -- $@
+OPTS="--display=quiet --profile=release"
+exec dune exec $OPTS ./src/bin/http_of_dir.exe -- $@

src/Tiny_httpd.ml

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

src/Tiny_httpd.mli

@@ -1,7 +1,7 @@
 (** Tiny Http Server
 
     This library implements a very simple, basic HTTP/1.1 server using blocking
-    IOs and threads. Basic routing based on {!Scanf} is provided for convenience,
+    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].
@@ -79,35 +79,99 @@ echo:
     processing streams and parsing requests.
 *)
 
-module Buf = Tiny_httpd_buf
-
-(** {2 Generic byte streams} *)
-
-module Byte_stream = Tiny_httpd_stream
+module Buf = Buf
 
 (** {2 IO Abstraction} *)
 
-module IO = Tiny_httpd_io
+module IO = Tiny_httpd_core.IO
 
-(** {2 Main Server Type} *)
+(** {2 Logging *)
 
-(** @inline *)
-include module type of struct
-  include Tiny_httpd_server
-end
+module Log = Tiny_httpd_core.Log
 
 (** {2 Utils} *)
 
-module Util = Tiny_httpd_util
+module Util = Tiny_httpd_core.Util
 
 (** {2 Resource pool} *)
 
-module Pool = Tiny_httpd_pool
+module Pool = Tiny_httpd_core.Pool
 
 (** {2 Static directory serving} *)
 
-module Dir = Tiny_httpd_dir
+module Dir = Tiny_httpd_unix.Dir
+
+module type VFS = Tiny_httpd_unix.Dir.VFS
+
+(** {2 HTML combinators} *)
 
 module Html = Tiny_httpd_html
 (** Alias to {!Tiny_httpd_html}
     @since 0.12 *)
+
+(** {2 Main server types} *)
+
+module Request = Tiny_httpd_core.Request
+module Response = Tiny_httpd_core.Response
+module Response_code = Tiny_httpd_core.Response_code
+module Route = Tiny_httpd_core.Route
+module Headers = Tiny_httpd_core.Headers
+module Meth = Tiny_httpd_core.Meth
+module Server = Tiny_httpd_core.Server
+
+(** @inline *)
+include module type of struct
+  include Server
+end
+
+val create :
+  ?enable_logging:bool ->
+  ?masksigpipe:bool ->
+  ?max_connections:int ->
+  ?timeout:float ->
+  ?buf_size:int ->
+  ?get_time_s:(unit -> float) ->
+  ?new_thread:((unit -> unit) -> unit) ->
+  ?addr:string ->
+  ?port:int ->
+  ?sock:Unix.file_descr ->
+  ?head_middlewares:Head_middleware.t list ->
+  ?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
+  unit ->
+  t
+(** Create a new webserver using UNIX abstractions.
+
+    The server will not do anything until {!run} is called on it.
+    Before starting the server, one can use {!add_path_handler} and
+    {!set_top_handler} to specify how to handle incoming requests.
+
+    @param masksigpipe if true, block the signal {!Sys.sigpipe} which otherwise
+    tends to kill client threads when they try to write on broken sockets.
+    Default: [true] 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 middlewares see {!add_middleware} for more details.
+
+    @param max_connections maximum number of simultaneous connections.
+    @param timeout connection is closed if the socket does not do read or
+      write for the amount of second. Default: 0.0 which means no timeout.
+      timeout is not recommended when using proxy.
+    @param addr address (IPv4 or IPv6) to listen on. Default ["127.0.0.1"].
+    @param port to listen on. Default [8080].
+    @param sock an existing socket given to the server to listen on, e.g. by
+      systemd on Linux (or launchd on macOS). If passed in, this socket will be
+      used instead of the [addr] and [port]. If not passed in, those will be
+      used. This parameter exists since 0.10.
+    @param 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.
+*)

src/Tiny_httpd_io.ml

@@ -1,226 +0,0 @@
-(** IO abstraction.
-
-    We abstract IO so we can support classic unix blocking IOs
-    with threads, and modern async IO with Eio.
-
-    {b NOTE}: experimental.
-
-    @since 0.14
-*)
-
-module Buf = Tiny_httpd_buf
-
-(** Input channel (byte source) *)
-module Input = struct
-  type t = {
-    input: bytes -> int -> int -> int;
-        (** Read into the slice. Returns [0] only if the
-        channel is closed. *)
-    close: unit -> unit;  (** Close the input. Must be idempotent. *)
-  }
-  (** An input channel, i.e an incoming stream of bytes.
-
-      This can be a [string], an [int_channel], an [Unix.file_descr], a
-      decompression wrapper around another input channel, etc. *)
-
-  let of_in_channel ?(close_noerr = false) (ic : in_channel) : t =
-    {
-      input = (fun buf i len -> input ic buf i len);
-      close =
-        (fun () ->
-          if close_noerr then
-            close_in_noerr ic
-          else
-            close_in ic);
-    }
-
-  let of_unix_fd ?(close_noerr = false) (fd : Unix.file_descr) : t =
-    {
-      input = (fun buf i len -> Unix.read fd buf i len);
-      close =
-        (fun () ->
-          if close_noerr then (
-            try Unix.close fd with _ -> ()
-          ) else
-            Unix.close fd);
-    }
-
-  (** Read into the given slice.
-      @return the number of bytes read, [0] means end of input. *)
-  let[@inline] input (self : t) buf i len = self.input buf i len
-
-  (** Close the channel. *)
-  let[@inline] close self : unit = self.close ()
-end
-
-(** Output channel (byte sink) *)
-module Output = struct
-  type t = {
-    output_char: char -> unit;  (** Output a single char *)
-    output: bytes -> int -> int -> unit;  (** Output slice *)
-    flush: unit -> unit;  (** Flush underlying buffer *)
-    close: unit -> unit;  (** Close the output. Must be idempotent. *)
-  }
-  (** An output channel, ie. a place into which we can write bytes.
-
-      This can be a [Buffer.t], an [out_channel], a [Unix.file_descr], etc. *)
-
-  (** [of_out_channel oc] wraps the channel into a {!Output.t}.
-      @param close_noerr if true, then closing the result uses [close_out_noerr]
-      instead of [close_out] to close [oc] *)
-  let of_out_channel ?(close_noerr = false) (oc : out_channel) : t =
-    {
-      output_char = (fun c -> output_char oc c);
-      output = (fun buf i len -> output oc buf i len);
-      flush = (fun () -> flush oc);
-      close =
-        (fun () ->
-          if close_noerr then
-            close_out_noerr oc
-          else
-            close_out oc);
-    }
-
-  (** [of_buffer buf] is an output channel that writes directly into [buf].
-        [flush] and [close] have no effect. *)
-  let of_buffer (buf : Buffer.t) : t =
-    {
-      output_char = Buffer.add_char buf;
-      output = Buffer.add_subbytes buf;
-      flush = ignore;
-      close = ignore;
-    }
-
-  (** Output the buffer slice into this channel *)
-  let[@inline] output_char (self : t) c : unit = self.output_char c
-
-  (** Output the buffer slice into this channel *)
-  let[@inline] output (self : t) buf i len : unit = self.output buf i len
-
-  let[@inline] output_string (self : t) (str : string) : unit =
-    self.output (Bytes.unsafe_of_string str) 0 (String.length str)
-
-  (** Close the channel. *)
-  let[@inline] close self : unit = self.close ()
-
-  (** Flush (ie. force write) any buffered bytes. *)
-  let[@inline] flush self : unit = self.flush ()
-
-  let output_buf (self : t) (buf : Buf.t) : unit =
-    let b = Buf.bytes_slice buf in
-    output self b 0 (Buf.size buf)
-
-  (** [chunk_encoding oc] makes a new channel that outputs its content into [oc]
-      in chunk encoding form.
-      @param close_rec if true, closing the result will also close [oc]
-      @param buf a buffer used to accumulate data into chunks.
-        Chunks are emitted when [buf]'s size gets over a certain threshold,
-        or when [flush] is called.
-      *)
-  let chunk_encoding ?(buf = Buf.create ()) ~close_rec (self : t) : t =
-    (* write content of [buf] as a chunk if it's big enough.
-       If [force=true] then write content of [buf] if it's simply non empty. *)
-    let write_buf ~force () =
-      let n = Buf.size buf in
-      if (force && n > 0) || n > 4_096 then (
-        output_string self (Printf.sprintf "%x\r\n" n);
-        self.output (Buf.bytes_slice buf) 0 n;
-        output_string self "\r\n";
-        Buf.clear buf
-      )
-    in
-
-    let flush () =
-      write_buf ~force:true ();
-      self.flush ()
-    in
-
-    let close () =
-      write_buf ~force:true ();
-      (* write an empty chunk to close the stream *)
-      output_string self "0\r\n";
-      (* write another crlf after the stream (see #56) *)
-      output_string self "\r\n";
-      self.flush ();
-      if close_rec then self.close ()
-    in
-    let output b i n =
-      Buf.add_bytes buf b i n;
-      write_buf ~force:false ()
-    in
-
-    let output_char c =
-      Buf.add_char buf c;
-      write_buf ~force:false ()
-    in
-    { output_char; flush; close; output }
-end
-
-(** A writer abstraction. *)
-module Writer = struct
-  type t = { write: Output.t -> unit } [@@unboxed]
-  (** Writer.
-
-    A writer is a push-based stream of bytes.
-    Give it an output channel and it will write the bytes in it.
-
-    This is useful for responses: an http endpoint can return a writer
-    as its response's body; the writer is given access to the connection
-    to the client and can write into it as if it were a regular
-    [out_channel], including controlling calls to [flush].
-    Tiny_httpd will convert these writes into valid HTTP chunks.
-    @since 0.14
-    *)
-
-  let[@inline] make ~write () : t = { write }
-
-  (** Write into the channel. *)
-  let[@inline] write (oc : Output.t) (self : t) : unit = self.write oc
-
-  (** Empty writer, will output 0 bytes. *)
-  let empty : t = { write = ignore }
-
-  (** A writer that just emits the bytes from the given string. *)
-  let[@inline] of_string (str : string) : t =
-    let write oc = Output.output_string oc str in
-    { write }
-end
-
-(** A TCP server abstraction. *)
-module TCP_server = struct
-  type conn_handler = {
-    handle: client_addr:Unix.sockaddr -> Input.t -> Output.t -> unit;
-        (** Handle client connection *)
-  }
-
-  type t = {
-    endpoint: unit -> string * int;
-        (** Endpoint we listen on. This can only be called from within [serve]. *)
-    active_connections: unit -> int;
-        (** Number of connections currently active *)
-    running: unit -> bool;  (** Is the server currently running? *)
-    stop: unit -> unit;
-        (** Ask the server to stop. This might not take effect immediately,
-      and is idempotent. After this [server.running()] must return [false]. *)
-  }
-  (** A running TCP server.
-
-     This contains some functions that provide information about the running
-     server, including whether it's active (as opposed to stopped), a function
-     to stop it, and statistics about the number of connections. *)
-
-  type builder = {
-    serve: after_init:(t -> unit) -> handle:conn_handler -> unit -> unit;
-        (** Blocking call to listen for incoming connections and handle them.
-            Uses the connection handler [handle] to handle individual client
-            connections in individual threads/fibers/tasks.
-            @param after_init is called once with the server after the server
-            has started. *)
-  }
-  (** A TCP server builder implementation.
-
-      Calling [builder.serve ~after_init ~handle ()] starts a new TCP server on
-      an unspecified endpoint
-      (most likely coming from the function returning this builder)
-      and returns the running server. *)
-end

src/Tiny_httpd_server.mli

@@ -1,674 +0,0 @@
-(** HTTP server.
-
-    This module implements a very simple, basic HTTP/1.1 server using blocking
-    IOs and threads.
-
-    It is possible to use a thread pool, see {!create}'s argument [new_thread].
-
-    @since 0.13
-*)
-
-type buf = Tiny_httpd_buf.t
-type byte_stream = Tiny_httpd_stream.t
-
-(** {2 HTTP Methods} *)
-
-module Meth : sig
-  type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
-  (** A HTTP method.
-      For now we only handle a subset of these.
-
-      See https://tools.ietf.org/html/rfc7231#section-4 *)
-
-  val pp : Format.formatter -> t -> unit
-  val to_string : t -> string
-end
-
-(** {2 Headers}
-
-    Headers are metadata associated with a request or response. *)
-
-module Headers : sig
-  type t = (string * string) list
-  (** The header files of a request or response.
-
-      Neither the key nor the value can contain ['\r'] or ['\n'].
-      See https://tools.ietf.org/html/rfc7230#section-3.2 *)
-
-  val empty : t
-  (** Empty list of headers.
-      @since 0.5 *)
-
-  val get : ?f:(string -> string) -> string -> t -> string option
-  (** [get k headers] looks for the header field with key [k].
-      @param f if provided, will transform the value before it is returned. *)
-
-  val set : string -> string -> t -> t
-  (** [set k v headers] sets the key [k] to value [v].
-      It erases any previous entry for [k] *)
-
-  val remove : string -> t -> t
-  (** Remove the key from the headers, if present. *)
-
-  val contains : string -> t -> bool
-  (** Is there a header with the given key? *)
-
-  val pp : Format.formatter -> t -> unit
-  (** Pretty print the headers. *)
-end
-
-(** {2 Requests}
-
-    Requests are sent by a client, e.g. a web browser or cURL.
-    From the point of view of the server, they're inputs. *)
-
-module Request : sig
-  type 'body t = private {
-    meth: Meth.t;  (** HTTP method for this request. *)
-    host: string;
-        (** Host header, mandatory. It can also be found in {!headers}. *)
-    client_addr: Unix.sockaddr;
-        (** Client address. Available since 0.14. *)
-    headers: Headers.t;  (** List of headers. *)
-    http_version: int * int;
-        (** HTTP version. This should be either [1, 0] or [1, 1]. *)
-    path: string;  (** Full path of the requested URL. *)
-    path_components: string list;
-        (** Components of the path of the requested URL. *)
-    query: (string * string) list;  (** Query part of the requested URL. *)
-    body: 'body;  (** Body of the request. *)
-    start_time: float;
-        (** Obtained via [get_time_s] in {!create}
-        @since 0.11 *)
-  }
-  (** A request with method, path, host, headers, and a body, sent by a client.
-
-      The body is polymorphic because the request goes through
-      several transformations. First it has no body, as only the request
-      and headers are read; then it has a stream body; then the body might be
-      entirely read as a string via {!read_body_full}.
-
-      @since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"]
-      @since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"].
-      @since 0.11 the type is a private alias
-      @since 0.11 the field [start_time] was added
-  *)
-
-  val pp : Format.formatter -> string t -> unit
-  (** Pretty print the request and its body. The exact format of this printing
-      is not specified. *)
-
-  val pp_ : Format.formatter -> _ t -> unit
-  (** Pretty print the request without its body. The exact format of this printing
-      is not specified. *)
-
-  val headers : _ t -> Headers.t
-  (** List of headers of the request, including ["Host"]. *)
-
-  val get_header : ?f:(string -> string) -> _ t -> string -> string option
-  (** [get_header req h] looks up header [h] in [req]. It returns [None] if the
-      header is not present. This is case insensitive and should be used
-      rather than looking up [h] verbatim in [headers]. *)
-
-  val get_header_int : _ t -> string -> int option
-  (** Same as {!get_header} but also performs a string to integer conversion. *)
-
-  val set_header : string -> string -> 'a t -> 'a t
-  (** [set_header k v req] sets [k: v] in the request [req]'s headers. *)
-
-  val update_headers : (Headers.t -> Headers.t) -> 'a t -> 'a t
-  (** Modify headers using the given function.
-      @since 0.11 *)
-
-  val set_body : 'a -> _ t -> 'a t
-  (** [set_body b req] returns a new query whose body is [b].
-      @since 0.11 *)
-
-  val host : _ t -> string
-  (** Host field of the request. It also appears in the headers. *)
-
-  val meth : _ t -> Meth.t
-  (** Method for the request. *)
-
-  val path : _ t -> string
-  (** Request path. *)
-
-  val query : _ t -> (string * string) list
-  (** Decode the query part of the {!path} field.
-      @since 0.4 *)
-
-  val body : 'b t -> 'b
-  (** Request body, possibly empty. *)
-
-  val start_time : _ t -> float
-  (** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the request
-      @since 0.11 *)
-
-  val limit_body_size : max_size:int -> byte_stream t -> byte_stream t
-  (** Limit the body size to [max_size] bytes, or return
-      a [413] error.
-      @since 0.3
-  *)
-
-  val read_body_full :
-    ?buf:Tiny_httpd_buf.t -> ?buf_size:int -> byte_stream t -> string t
-  (** Read the whole body into a string. Potentially blocking.
-
-      @param buf_size initial size of underlying buffer (since 0.11)
-      @param buf the initial buffer (since 0.14)
-      *)
-
-  (**/**)
-
-  (* for testing purpose, do not use.  There is no guarantee of stability. *)
-  module Internal_ : sig
-    val parse_req_start :
-      ?buf:buf ->
-      client_addr:Unix.sockaddr ->
-      get_time_s:(unit -> float) ->
-      byte_stream ->
-      unit t option
-
-    val parse_body : ?buf:buf -> unit t -> byte_stream -> byte_stream t
-  end
-
-  (**/**)
-end
-
-(** {2 Response Codes} *)
-
-module Response_code : sig
-  type t = int
-  (** A standard HTTP code.
-
-      https://tools.ietf.org/html/rfc7231#section-6 *)
-
-  val ok : t
-  (** The code [200] *)
-
-  val not_found : t
-  (** The code [404] *)
-
-  val descr : t -> string
-  (** A description of some of the error codes.
-      NOTE: this is not complete (yet). *)
-end
-
-(** {2 Responses}
-
-    Responses are what a http server, such as {!Tiny_httpd}, send back to
-    the client to answer a {!Request.t}*)
-
-module Response : sig
-  type body =
-    [ `String of string
-    | `Stream of byte_stream
-    | `Writer of Tiny_httpd_io.Writer.t
-    | `Void ]
-  (** Body of a response, either as a simple string,
-      or a stream of bytes, or nothing (for server-sent events notably).
-
-      - [`String str] replies with a body set to this string, and a known content-length.
-      - [`Stream str] replies with a body made from this string, using chunked encoding.
-      - [`Void] replies with no body.
-      - [`Writer w] replies with a body created by the writer [w], using
-          a chunked encoding.
-        It is available since 0.14.
-  *)
-
-  type t = private {
-    code: Response_code.t;  (** HTTP response code. See {!Response_code}. *)
-    headers: Headers.t;
-        (** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *)
-    body: body;  (** Body of the response. Can be empty. *)
-  }
-  (** A response to send back to a client. *)
-
-  val set_body : body -> t -> t
-  (** Set the body of the response.
-      @since 0.11 *)
-
-  val set_header : string -> string -> t -> t
-  (** Set a header.
-      @since 0.11 *)
-
-  val update_headers : (Headers.t -> Headers.t) -> t -> t
-  (** Modify headers.
-      @since 0.11 *)
-
-  val set_headers : Headers.t -> t -> t
-  (** Set all headers.
-      @since 0.11 *)
-
-  val set_code : Response_code.t -> t -> t
-  (** Set the response code.
-      @since 0.11 *)
-
-  val make_raw : ?headers:Headers.t -> code:Response_code.t -> string -> t
-  (** Make a response from its raw components, with a string body.
-      Use [""] to not send a body at all. *)
-
-  val make_raw_stream :
-    ?headers:Headers.t -> code:Response_code.t -> byte_stream -> t
-  (** Same as {!make_raw} but with a stream body. The body will be sent with
-      the chunked transfer-encoding. *)
-
-  val make_void : ?headers:Headers.t -> code:int -> unit -> t
-  (** Return a response without a body at all.
-      @since 0.13 *)
-
-  val make :
-    ?headers:Headers.t ->
-    ?code:int ->
-    (body, Response_code.t * string) result ->
-    t
-  (** [make r] turns a result into a response.
-
-      - [make (Ok body)] replies with [200] and the body.
-      - [make (Error (code,msg))] replies with the given error code
-        and message as body.
-  *)
-
-  val make_string :
-    ?headers:Headers.t ->
-    ?code:int ->
-    (string, Response_code.t * string) result ->
-    t
-  (** Same as {!make} but with a string body. *)
-
-  val make_writer :
-    ?headers:Headers.t ->
-    ?code:int ->
-    (Tiny_httpd_io.Writer.t, Response_code.t * string) result ->
-    t
-  (** Same as {!make} but with a writer body. *)
-
-  val make_stream :
-    ?headers:Headers.t ->
-    ?code:int ->
-    (byte_stream, Response_code.t * string) result ->
-    t
-  (** Same as {!make} but with a stream body. *)
-
-  val fail :
-    ?headers:Headers.t -> code:int -> ('a, unit, string, t) format4 -> 'a
-  (** Make the current request fail with the given code and message.
-      Example: [fail ~code:404 "oh noes, %s not found" "waldo"].
-  *)
-
-  val fail_raise : code:int -> ('a, unit, string, 'b) format4 -> 'a
-  (** Similar to {!fail} but raises an exception that exits the current handler.
-      This should not be used outside of a (path) handler.
-      Example: [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
-  *)
-
-  val pp : Format.formatter -> t -> unit
-  (** Pretty print the response. The exact format is not specified. *)
-end
-
-(** {2 Routing}
-
-    Basic type-safe routing of handlers based on URL paths. This is optional,
-    it is possible to only define the root handler with something like
-    {{: https://github.com/anuragsoni/routes/} Routes}.
-    @since 0.6 *)
-
-module Route : sig
-  type ('a, 'b) comp
-  (** An atomic component of a path *)
-
-  type ('a, 'b) t
-  (** A route, composed of path components *)
-
-  val int : (int -> 'a, 'a) comp
-  (** Matches an integer. *)
-
-  val string : (string -> 'a, 'a) comp
-  (** Matches a string not containing ['/'] and binds it as is. *)
-
-  val string_urlencoded : (string -> 'a, 'a) comp
-  (** Matches a URL-encoded string, and decodes it. *)
-
-  val exact : string -> ('a, 'a) comp
-  (** [exact "s"] matches ["s"] and nothing else. *)
-
-  val return : ('a, 'a) t
-  (** Matches the empty path. *)
-
-  val rest_of_path : (string -> 'a, 'a) t
-  (** Matches a string, even containing ['/']. This will match
-      the entirety of the remaining route.
-      @since 0.7 *)
-
-  val rest_of_path_urlencoded : (string -> 'a, 'a) t
-  (** Matches a string, even containing ['/'], an URL-decode it.
-      This will match the entirety of the remaining route.
-      @since 0.7 *)
-
-  val ( @/ ) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t
-  (** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"],
-      and [route] matches ["bar/…"]. *)
-
-  val exact_path : string -> ('a, 'b) t -> ('a, 'b) t
-  (** [exact_path "foo/bar/..." r] is equivalent to
-      [exact "foo" @/ exact "bar" @/ ... @/ r]
-      @since 0.11 **)
-
-  val pp : Format.formatter -> _ t -> unit
-  (** Print the route.
-      @since 0.7 *)
-
-  val to_string : _ t -> string
-  (** Print the route.
-      @since 0.7 *)
-end
-
-(** {2 Middlewares}
-
-    A middleware can be inserted in a handler to modify or observe
-    its behavior.
-
-    @since 0.11
-*)
-
-module Middleware : sig
-  type handler = byte_stream Request.t -> resp:(Response.t -> unit) -> unit
-  (** Handlers are functions returning a response to a request.
-      The response can be delayed, hence the use of a continuation
-      as the [resp] parameter. *)
-
-  type t = handler -> handler
-  (** A middleware is a handler transformation.
-
-      It takes the existing handler [h],
-      and returns a new one which, given a query, modify it or log it
-      before passing it to [h], or fail. It can also log or modify or drop
-      the response. *)
-
-  val nil : t
-  (** Trivial middleware that does nothing. *)
-end
-
-(** {2 Main Server type} *)
-
-type t
-(** A HTTP server. See {!create} for more details. *)
-
-val create :
-  ?masksigpipe:bool ->
-  ?max_connections:int ->
-  ?timeout:float ->
-  ?buf_size:int ->
-  ?get_time_s:(unit -> float) ->
-  ?new_thread:((unit -> unit) -> unit) ->
-  ?addr:string ->
-  ?port:int ->
-  ?sock:Unix.file_descr ->
-  ?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
-  unit ->
-  t
-(** Create a new webserver using UNIX abstractions.
-
-    The server will not do anything until {!run} is called on it.
-    Before starting the server, one can use {!add_path_handler} and
-    {!set_top_handler} to specify how to handle incoming requests.
-
-    @param masksigpipe if true, block the signal {!Sys.sigpipe} which otherwise
-    tends to kill client threads when they try to write on broken sockets. Default: [true].
-
-    @param buf_size size for buffers (since 0.11)
-
-    @param new_thread a function used to spawn a new thread to handle a
-    new client connection. By default it is {!Thread.create} but one
-    could use a thread pool instead.
-    See for example {{: https://github.com/c-cube/tiny-httpd-moonpool-bench/blob/0dcbbffb4fe34ea4ad79d46343ad0cebb69ca69f/examples/t1.ml#L31}
-      this use of moonpool}.
-
-    @param middlewares see {!add_middleware} for more details.
-
-    @param max_connections maximum number of simultaneous connections.
-    @param timeout connection is closed if the socket does not do read or
-      write for the amount of second. Default: 0.0 which means no timeout.
-      timeout is not recommended when using proxy.
-    @param addr address (IPv4 or IPv6) to listen on. Default ["127.0.0.1"].
-    @param port to listen on. Default [8080].
-    @param sock an existing socket given to the server to listen on, e.g. by
-      systemd on Linux (or launchd on macOS). If passed in, this socket will be
-      used instead of the [addr] and [port]. If not passed in, those will be
-      used. This parameter exists since 0.10.
-
-    @param get_time_s obtain the current timestamp in seconds.
-      This parameter exists since 0.11.
-*)
-
-(** A backend that provides IO operations, network operations, etc.
-
-    This is used to decouple tiny_httpd from the scheduler/IO library used to
-    actually open a TCP server and talk to clients. The classic way is
-    based on {!Unix} and blocking IOs, but it's also possible to
-    use an OCaml 5 library using effects and non blocking IOs. *)
-module type IO_BACKEND = sig
-  val init_addr : unit -> string
-  (** Initial TCP address *)
-
-  val init_port : unit -> int
-  (** Initial port *)
-
-  val get_time_s : unit -> float
-  (** Obtain the current timestamp in seconds. *)
-
-  val tcp_server : unit -> Tiny_httpd_io.TCP_server.builder
-  (** TCP server builder, to create servers that can listen
-      on a port and handle clients. *)
-end
-
-val create_from :
-  ?buf_size:int ->
-  ?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
-  backend:(module IO_BACKEND) ->
-  unit ->
-  t
-(** Create a new webserver using provided backend.
-
-    The server will not do anything until {!run} is called on it.
-    Before starting the server, one can use {!add_path_handler} and
-    {!set_top_handler} to specify how to handle incoming requests.
-
-    @param buf_size size for buffers (since 0.11)
-    @param middlewares see {!add_middleware} for more details.
-
-    @since 0.14
-*)
-
-val addr : t -> string
-(** Address on which the server listens. *)
-
-val is_ipv6 : t -> bool
-(** [is_ipv6 server] returns [true] iff the address of the server is an IPv6 address.
-    @since 0.3 *)
-
-val port : t -> int
-(** Port on which the server listens. Note that this might be different than
-    the port initially given if the port was [0] (meaning that the OS picks a
-    port for us). *)
-
-val active_connections : t -> int
-(** Number of currently active connections. *)
-
-val add_decode_request_cb :
-  t ->
-  (unit Request.t -> (unit Request.t * (byte_stream -> byte_stream)) option) ->
-  unit
-  [@@deprecated "use add_middleware"]
-(** Add a callback for every request.
-    The callback can provide a stream transformer and a new request (with
-    modified headers, typically).
-    A possible use is to handle decompression by looking for a [Transfer-Encoding]
-    header and returning a stream transformer that decompresses on the fly.
-
-    @deprecated use {!add_middleware} instead
-*)
-
-val add_encode_response_cb :
-  t -> (unit Request.t -> Response.t -> Response.t option) -> unit
-  [@@deprecated "use add_middleware"]
-(** Add a callback for every request/response pair.
-    Similarly to {!add_encode_response_cb} the callback can return a new
-    response, for example to compress it.
-    The callback is given the query with only its headers,
-    as well as the current response.
-
-    @deprecated use {!add_middleware} instead
-*)
-
-val add_middleware :
-  stage:[ `Encoding | `Stage of int ] -> t -> Middleware.t -> unit
-(** Add a middleware to every request/response pair.
-    @param stage specify when middleware applies.
-      Encoding comes first (outermost layer), then stages in increasing order.
-    @raise Invalid_argument if stage is [`Stage n] where [n < 1]
-    @since 0.11
-*)
-
-(** {2 Request handlers} *)
-
-val set_top_handler : t -> (byte_stream Request.t -> Response.t) -> unit
-(** Setup a handler called by default.
-
-    This handler is called with any request not accepted by any handler
-    installed via {!add_path_handler}.
-    If no top handler is installed, unhandled paths will return a [404] not found
-
-    This used to take a [string Request.t] but it now takes a [byte_stream Request.t]
-    since 0.14 . Use {!Request.read_body_full} to read the body into
-    a string if needed.
-*)
-
-val add_route_handler :
-  ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
-  ?middlewares:Middleware.t list ->
-  ?meth:Meth.t ->
-  t ->
-  ('a, string Request.t -> Response.t) Route.t ->
-  'a ->
-  unit
-(** [add_route_handler server Route.(exact "path" @/ string @/ int @/ return) f]
-    calls [f "foo" 42 request] when a [request] with path "path/foo/42/"
-    is received.
-
-    Note that the handlers are called in the reverse order of their addition,
-    so the last registered handler can override previously registered ones.
-
-    @param meth if provided, only accept requests with the given method.
-    Typically one could react to [`GET] or [`PUT].
-    @param accept should return [Ok()] if the given request (before its body
-    is read) should be accepted, [Error (code,message)] if it's to be rejected (e.g. because
-    its content is too big, or for some permission error).
-    See the {!http_of_dir} program for an example of how to use [accept] to
-    filter uploads that are too large before the upload even starts.
-    The default always returns [Ok()], i.e. it accepts all requests.
-
-    @since 0.6
-*)
-
-val add_route_handler_stream :
-  ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
-  ?middlewares:Middleware.t list ->
-  ?meth:Meth.t ->
-  t ->
-  ('a, byte_stream Request.t -> Response.t) Route.t ->
-  'a ->
-  unit
-(** Similar to {!add_route_handler}, but where the body of the request
-    is a stream of bytes that has not been read yet.
-    This is useful when one wants to stream the body directly into a parser,
-    json decoder (such as [Jsonm]) or into a file.
-    @since 0.6 *)
-
-(** {2 Server-sent events}
-
-    {b EXPERIMENTAL}: this API is not stable yet. *)
-
-(** A server-side function to generate of Server-sent events.
-
-    See {{: https://html.spec.whatwg.org/multipage/server-sent-events.html} the w3c page}
-    and {{: https://jvns.ca/blog/2021/01/12/day-36--server-sent-events-are-cool--and-a-fun-bug/}
-    this blog post}.
-
-    @since 0.9
-  *)
-module type SERVER_SENT_GENERATOR = sig
-  val set_headers : Headers.t -> unit
-  (** Set headers of the response.
-      This is not mandatory but if used at all, it must be called before
-      any call to {!send_event} (once events are sent the response is
-      already sent too). *)
-
-  val send_event :
-    ?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
-  (** Send an event from the server.
-      If data is a multiline string, it will be sent on separate "data:" lines. *)
-
-  val close : unit -> unit
-  (** Close connection.
-      @since 0.11 *)
-end
-
-type server_sent_generator = (module SERVER_SENT_GENERATOR)
-(** Server-sent event generator. This generates events that are forwarded to
-    the client (e.g. the browser).
-    @since 0.9 *)
-
-val add_route_server_sent_handler :
-  ?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
-  t ->
-  ('a, string Request.t -> server_sent_generator -> unit) Route.t ->
-  'a ->
-  unit
-(** Add a handler on an endpoint, that serves server-sent events.
-
-    The callback is given a generator that can be used to send events
-    as it pleases. The connection is always closed by the client,
-    and the accepted method is always [GET].
-    This will set the header "content-type" to "text/event-stream" automatically
-    and reply with a 200 immediately.
-    See {!server_sent_generator} for more details.
-
-    This handler stays on the original thread (it is synchronous).
-
-    @since 0.9 *)
-
-(** {2 Run the server} *)
-
-val running : t -> bool
-(** Is the server running?
-    @since 0.14 *)
-
-val stop : t -> unit
-(** Ask the server to stop. This might not have an immediate effect
-    as {!run} might currently be waiting on IO. *)
-
-val run : ?after_init:(unit -> unit) -> t -> (unit, exn) result
-(** Run the main loop of the server, listening on a socket
-    described at the server's creation time, using [new_thread] to
-    start a thread for each new client.
-
-    This returns [Ok ()] if the server exits gracefully, or [Error e] if
-    it exits with an error.
-
-    @param after_init is called after the server starts listening. since 0.13 .
-*)
-
-val run_exn : ?after_init:(unit -> unit) -> t -> unit
-(** [run_exn s] is like [run s] but re-raises an exception if the server exits
-    with an error.
-    @since 0.14 *)
-
-(**/**)
-
-val _debug :
-  ((('a, out_channel, unit, unit, unit, unit) format6 -> 'a) -> unit) -> unit
-
-val _enable_debug : bool -> unit
-
-(**/**)

src/bin/http_of_dir.ml

@@ -1,16 +1,15 @@
 module S = Tiny_httpd
-module U = Tiny_httpd_util
-module D = Tiny_httpd_dir
-module Pf = Printf
+module D = Tiny_httpd.Dir
+module Log = Tiny_httpd.Log
 
-let serve ~config (dir : string) addr port j : _ result =
-  let server = S.create ~max_connections:j ~addr ~port () in
+let serve ~config ~timeout (dir : string) addr port j : _ result =
+  let server = S.create ~max_connections:j ~addr ~port ~timeout () in
   let after_init () =
     Printf.printf "serve directory %s on http://%(%s%):%d\n%!" dir
       (if S.is_ipv6 server then
-        "[%s]"
-      else
-        "%s")
+         "[%s]"
+       else
+         "%s")
       addr (S.port server)
   in
 
@@ -30,6 +29,7 @@ let main () =
   let dir_ = ref "." in
   let addr = ref "127.0.0.1" in
   let port = ref 8080 in
+  let timeout = ref 30. in
   let j = ref 32 in
   Arg.parse
     (Arg.align
@@ -39,7 +39,8 @@ let main () =
          "--port", Set_int port, " port to listen on";
          "-p", Set_int port, " alias to --port";
          "--dir", Set_string dir_, " directory to serve (default: \".\")";
-         "--debug", Unit (fun () -> S._enable_debug true), " debug mode";
+         "--debug", Unit (Log.setup ~debug:true), " debug mode";
+         "--timeout", Arg.Set_float timeout, " TCP timeout on sockets";
          ( "--upload",
            Unit (fun () -> config.upload <- true),
            " enable file uploading" );
@@ -60,9 +61,9 @@ let main () =
              (fun b ->
                config.dir_behavior <-
                  (if b then
-                   Index_or_lists
-                 else
-                   Lists)),
+                    Index_or_lists
+                  else
+                    Lists)),
            " <bool> automatically redirect to index.html if present" );
          ( "--delete",
            Unit (fun () -> config.delete <- true),
@@ -74,7 +75,7 @@ let main () =
        ])
     (fun s -> dir_ := s)
     "http_of_dir [options] [dir]";
-  match serve ~config !dir_ !addr !port !j with
+  match serve ~config ~timeout:!timeout !dir_ !addr !port !j with
   | Ok () -> ()
   | Error e -> raise e
 

src/bin/vfs_pack.ml

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

src/camlzip/Tiny_httpd_camlzip.ml

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

src/camlzip/Tiny_httpd_camlzip.mli

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

src/camlzip/dune

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

src/core/IO.ml

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

src/core/buf.ml

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

src/core/buf.mli

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

src/core/common_.ml

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

src/core/dune

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

src/core/gen/dune

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

src/core/gen/mkshims.ml

@@ -26,11 +26,6 @@ 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

src/core/headers.ml

@@ -0,0 +1,103 @@
+open Common_
+
+type t = (string * string) list
+
+let empty = []
+
+(* [Char.lowercase_ascii] but easier to inline *)
+let[@inline] lower_char_ = function
+  | 'A' .. 'Z' as c -> Char.unsafe_chr (Char.code c + 32)
+  | c -> c
+
+(** Are these two header names equal? This is case insensitive *)
+let equal_name_ (s1 : string) (s2 : string) : bool =
+  String.length s1 = String.length s2
+  &&
+  try
+    for i = 0 to String.length s1 - 1 do
+      let c1 = String.unsafe_get s1 i |> lower_char_ in
+      let c2 = String.unsafe_get s2 i |> lower_char_ in
+      if c1 <> c2 then raise_notrace Exit
+    done;
+    true
+  with Exit -> false
+
+let contains name headers =
+  List.exists (fun (n, _) -> equal_name_ name n) headers
+
+let rec get_exn ?(f = fun x -> x) x h =
+  match h with
+  | [] -> raise Not_found
+  | (k, v) :: _ when equal_name_ x k -> f v
+  | _ :: tl -> get_exn ~f x tl
+
+let get ?(f = fun x -> x) x h =
+  try Some (get_exn ~f x h) with Not_found -> None
+
+let remove x h = List.filter (fun (k, _) -> not (equal_name_ k x)) h
+
+let set x y h =
+  let h =
+    if contains x h then
+      remove x h
+    else
+      h
+  in
+  (x, y) :: h
+
+let pp out l =
+  let pp_pair out (k, v) = Format.fprintf out "@[<h>%s: %s@]" k v in
+  Format.fprintf out "@[<v>%a@]" (Format.pp_print_list pp_pair) l
+
+(* token = 1*tchar
+   tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" / "_"
+            / "`" / "|" / "~" / DIGIT / ALPHA ; any VCHAR, except delimiters
+   Reference: https://datatracker.ietf.org/doc/html/rfc7230#section-3.2 *)
+let is_tchar = function
+  | '0' .. '9'
+  | 'a' .. 'z'
+  | 'A' .. 'Z'
+  | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' | '_' | '`'
+  | '|' | '~' ->
+    true
+  | _ -> false
+
+let for_all pred s =
+  try
+    String.iter (fun c -> if not (pred c) then raise Exit) s;
+    true
+  with Exit -> false
+
+let parse_line_ (line : string) : _ result =
+  try
+    let i =
+      try String.index line ':'
+      with Not_found -> failwith "invalid header, missing ':'"
+    in
+    let k = String.sub line 0 i in
+    if not (for_all is_tchar k) then
+      failwith (Printf.sprintf "Invalid header key: %S" k);
+    let v =
+      String.sub line (i + 1) (String.length line - i - 1) |> String.trim
+    in
+    Ok (k, v)
+  with Failure msg -> Error msg
+
+let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
+  let rec loop acc =
+    match IO.Input.read_line_using_opt ~buf bs with
+    | None -> raise End_of_file
+    | Some "" -> assert false
+    | Some "\r" -> acc
+    | Some line when line.[String.length line - 1] <> '\r' ->
+      bad_reqf 400 "bad header line, not ended in CRLF"
+    | Some line ->
+      let k, v =
+        match parse_line_ line with
+        | Ok r -> r
+        | Error msg ->
+          bad_reqf 400 "invalid header line: %s\nline is: %S" msg line
+      in
+      loop ((k, v) :: acc)
+  in
+  loop []

src/core/headers.mli

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

src/core/log.default.ml

@@ -0,0 +1,8 @@
+(* default: no logging *)
+
+let info _ = ()
+let debug _ = ()
+let error _ = ()
+let setup ~debug:_ () = ()
+let dummy = true
+let fully_disable = ignore

src/core/log.logs.ml

@@ -0,0 +1,25 @@
+(* Use Logs *)
+
+let log_src = Logs.Src.create "tiny_httpd"
+
+module Log = (val Logs.(src_log log_src))
+
+let info k = Log.info (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
+let debug k = Log.debug (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
+let error k = Log.err (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x))
+
+let setup ~debug () =
+  let mutex = Mutex.create () in
+  Logs.set_reporter_mutex
+    ~lock:(fun () -> Mutex.lock mutex)
+    ~unlock:(fun () -> Mutex.unlock mutex);
+  Logs.set_reporter @@ Logs.format_reporter ();
+  Logs.set_level ~all:true
+    (Some
+       (if debug then
+          Logs.Debug
+        else
+          Logs.Info))
+
+let dummy = false
+let fully_disable () = Logs.Src.set_level log_src None

src/core/log.mli

@@ -0,0 +1,17 @@
+(** Logging for tiny_httpd *)
+
+val info : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
+val debug : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
+val error : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit
+
+val setup : debug:bool -> unit -> unit
+(** Setup and enable logging. This should only ever be used in executables,
+    not libraries.
+    @param debug if true, set logging to debug (otherwise info) *)
+
+val dummy : bool
+
+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 *)

src/core/meth.ml

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

src/core/meth.mli

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

src/core/parse_.ml

@@ -0,0 +1,77 @@
+(** Basic parser for lines *)
+
+type 'a t = string -> int ref -> 'a
+
+open struct
+  let spf = Printf.sprintf
+end
+
+let[@inline] eof s off = !off = String.length s
+
+let[@inline] skip_space : unit t =
+ fun s off ->
+  while !off < String.length s && String.unsafe_get s !off = ' ' do
+    incr off
+  done
+
+let pos_int : int t =
+ fun s off : int ->
+  skip_space s off;
+  let n = ref 0 in
+  let continue = ref true in
+  while !off < String.length s && !continue do
+    match String.unsafe_get s !off with
+    | '0' .. '9' as c -> n := (!n * 10) + Char.code c - Char.code '0'
+    | ' ' | '\t' | '\n' -> continue := false
+    | c -> failwith @@ spf "expected int, got %C" c
+  done;
+  !n
+
+let pos_hex : int t =
+ fun s off : int ->
+  skip_space s off;
+  let n = ref 0 in
+  let continue = ref true in
+  while !off < String.length s && !continue do
+    match String.unsafe_get s !off with
+    | 'a' .. 'f' as c ->
+      incr off;
+      n := (!n * 16) + Char.code c - Char.code 'a' + 10
+    | 'A' .. 'F' as c ->
+      incr off;
+      n := (!n * 16) + Char.code c - Char.code 'A' + 10
+    | '0' .. '9' as c ->
+      incr off;
+      n := (!n * 16) + Char.code c - Char.code '0'
+    | ' ' | '\r' -> continue := false
+    | c -> failwith @@ spf "expected int, got %C" c
+  done;
+  !n
+
+(** Parse a word without spaces *)
+let word : string t =
+ fun s off ->
+  skip_space s off;
+  let start = !off in
+  let continue = ref true in
+  while !off < String.length s && !continue do
+    match String.unsafe_get s !off with
+    | ' ' | '\r' -> continue := false
+    | _ -> incr off
+  done;
+  if !off = start then failwith "expected word";
+  String.sub s start (!off - start)
+
+let exact str : unit t =
+ fun s off ->
+  skip_space s off;
+  let len = String.length str in
+  if !off + len > String.length s then
+    failwith @@ spf "unexpected EOF, expected %S" str;
+  for i = 0 to len - 1 do
+    let expected = String.unsafe_get str i in
+    let c = String.unsafe_get s (!off + i) in
+    if c <> expected then
+      failwith @@ spf "expected %S, got %C at position %d" str c i
+  done;
+  off := !off + len

src/core/pool.ml

@@ -1,4 +1,4 @@
-module A = Tiny_httpd_atomic_
+module A = Atomic_
 
 type 'a list_ = Nil | Cons of int * 'a * 'a list_
 
@@ -12,20 +12,20 @@ type 'a t = {
 let create ?(clear = ignore) ~mk_item ?(max_size = 512) () : _ t =
   { mk_item; clear; max_size; items = A.make Nil }
 
-let rec acquire_ self =
+let rec acquire self =
   match A.get self.items with
   | Nil -> self.mk_item ()
   | Cons (_, x, tl) as l ->
     if A.compare_and_set self.items l tl then
       x
     else
-      acquire_ self
+      acquire self
 
 let[@inline] size_ = function
   | Cons (sz, _, _) -> sz
   | Nil -> 0
 
-let release_ self x : unit =
+let release self x : unit =
   let rec loop () =
     match A.get self.items with
     | Cons (sz, _, _) when sz >= self.max_size ->
@@ -40,12 +40,17 @@ let release_ self x : unit =
   loop ()
 
 let with_resource (self : _ t) f =
-  let x = acquire_ self in
+  let x = acquire self in
   try
     let res = f x in
-    release_ self x;
+    release self x;
     res
   with e ->
     let bt = Printexc.get_raw_backtrace () in
-    release_ self x;
+    release self x;
     Printexc.raise_with_backtrace e bt
+
+module Raw = struct
+  let release = release
+  let acquire = acquire
+end

src/core/pool.mli

@@ -23,3 +23,12 @@ 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. *)
+
+(** 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
+end

src/core/request.ml

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

src/core/request.mli

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

src/core/response.ml

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

src/core/response.mli

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

src/core/response_code.ml

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

src/core/response_code.mli

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

src/core/route.ml

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

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

src/core/server.ml

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

src/core/server.mli

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

src/core/stream.ml.tmp

@@ -1,3 +1,4 @@
+(*
 module Buf = Tiny_httpd_buf
 module IO = Tiny_httpd_io
 
@@ -50,10 +51,11 @@ let of_input ?(buf_size = 16 * 1024) (ic : IO.Input.t) : t =
   make ~bs:(Bytes.create buf_size)
     ~close:(fun _ -> IO.Input.close ic)
     ~consume:(fun self n ->
+      assert (self.len >= n);
       self.off <- self.off + n;
       self.len <- self.len - n)
     ~fill:(fun self ->
-      if self.off >= self.len then (
+      if self.len = 0 then (
         self.off <- 0;
         self.len <- IO.Input.input ic self.bs 0 (Bytes.length self.bs)
       ))
@@ -66,22 +68,28 @@ let of_chan_ ?buf_size ic ~close_noerr : t =
 let of_chan ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:false
 let of_chan_close_noerr ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:true
 
-let of_fd_ ?buf_size ~close_noerr ic : t =
-  let inc = IO.Input.of_unix_fd ~close_noerr ic in
+let of_fd_ ?buf_size ~close_noerr ~closed ic : t =
+  let inc = IO.Input.of_unix_fd ~close_noerr ~closed ic in
   of_input ?buf_size inc
 
-let of_fd ?buf_size fd : t = of_fd_ ?buf_size ~close_noerr:false fd
-let of_fd_close_noerr ?buf_size fd : t = of_fd_ ?buf_size ~close_noerr:true fd
+let of_fd ?buf_size ~closed fd : t =
+  of_fd_ ?buf_size ~closed ~close_noerr:false fd
 
-let rec iter f (self : t) : unit =
-  self.fill_buf ();
-  if self.len = 0 then
-    self.close ()
-  else (
-    f self.bs self.off self.len;
-    self.consume self.len;
-    (iter [@tailcall]) f self
-  )
+let of_fd_close_noerr ?buf_size ~closed fd : t =
+  of_fd_ ?buf_size ~closed ~close_noerr:true fd
+
+let iter f (self : t) : unit =
+  let continue = ref true in
+  while !continue do
+    self.fill_buf ();
+    if self.len = 0 then (
+      continue := false;
+      self.close ()
+    ) else (
+      f self.bs self.off self.len;
+      self.consume self.len
+    )
+  done
 
 let to_chan (oc : out_channel) (self : t) = iter (output oc) self
 let to_chan' (oc : IO.Output.t) (self : t) = iter (IO.Output.output oc) self
@@ -116,7 +124,7 @@ let of_string s : t = of_bytes (Bytes.unsafe_of_string s)
 let with_file ?buf_size file f =
   let ic = Unix.(openfile file [ O_RDONLY ] 0) in
   try
-    let x = f (of_fd ?buf_size ic) in
+    let x = f (of_fd ?buf_size ~closed:(ref false) ic) in
     Unix.close ic;
     x
   with e ->
@@ -127,12 +135,13 @@ let read_all ?(buf = Buf.create ()) (self : t) : string =
   let continue = ref true in
   while !continue do
     self.fill_buf ();
-    if self.len > 0 then (
+    if self.len = 0 then
+      continue := false
+    else (
+      assert (self.len > 0);
       Buf.add_bytes buf self.bs self.off self.len;
       self.consume self.len
-    );
-    assert (self.len >= 0);
-    if self.len = 0 then continue := false
+    )
   done;
   Buf.contents_and_clear buf
 
@@ -165,10 +174,10 @@ let read_line_into (self : t) ~buf : unit =
     done;
     if !j - self.off < self.len then (
       assert (Bytes.get self.bs !j = '\n');
+      (* line without '\n' *)
       Buf.add_bytes buf self.bs self.off (!j - self.off);
-      (* without \n *)
+      (* consume line + '\n' *)
       self.consume (!j - self.off + 1);
-      (* remove \n *)
       continue := false
     ) else (
       Buf.add_bytes buf self.bs self.off self.len;
@@ -176,36 +185,6 @@ let read_line_into (self : t) ~buf : unit =
     )
   done
 
-(* new stream with maximum size [max_size].
-   @param close_rec if true, closing this will also close the input stream
-   @param too_big called with read size if the max size is reached *)
-let limit_size_to ~close_rec ~max_size ~too_big (arg : t) : t =
-  let size = ref 0 in
-  let continue = ref true in
-  make ~bs:Bytes.empty
-    ~close:(fun _ -> if close_rec then arg.close ())
-    ~fill:(fun res ->
-      if res.len = 0 && !continue then (
-        arg.fill_buf ();
-        res.bs <- arg.bs;
-        res.off <- arg.off;
-        res.len <- arg.len
-      ) else (
-        arg.bs <- Bytes.empty;
-        arg.off <- 0;
-        arg.len <- 0
-      ))
-    ~consume:(fun res n ->
-      size := !size + n;
-      if !size > max_size then (
-        continue := false;
-        too_big !size
-      ) else (
-        arg.consume n;
-        res.off <- res.off + n;
-        res.len <- res.len - n
-      ))
-    ()
 
 (* read exactly [size] bytes from the stream *)
 let read_exactly ~close_rec ~size ~too_short (arg : t) : t =
@@ -260,7 +239,10 @@ let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
       if String.trim line = "" then
         0
       else (
-        try Scanf.sscanf line "%x %s@\r" (fun n _ext -> n)
+        try
+          let off = ref 0 in
+          let n = Tiny_httpd_parse_.pos_hex line off in
+          n
         with _ ->
           raise (fail (spf "cannot read chunk size from line %S" line))
       )
@@ -273,7 +255,7 @@ let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
     ~bs:(Bytes.create (16 * 4096))
     ~fill:(fun self ->
       (* do we need to refill? *)
-      if self.off >= self.len then (
+      if self.len = 0 then (
         if !chunk_size = 0 && !refill then chunk_size := read_next_chunk_len ();
         self.off <- 0;
         self.len <- 0;
@@ -299,9 +281,14 @@ let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
 
 let output_chunked' ?buf (oc : IO.Output.t) (self : t) : unit =
   let oc' = IO.Output.chunk_encoding ?buf oc ~close_rec:false in
-  to_chan' oc' self;
-  IO.Output.close oc'
+  match to_chan' oc' self with
+  | () -> IO.Output.close oc'
+  | exception e ->
+    let bt = Printexc.get_raw_backtrace () in
+    IO.Output.close oc';
+    Printexc.raise_with_backtrace e bt
 
 (* print a stream as a series of chunks *)
 let output_chunked ?buf (oc : out_channel) (self : t) : unit =
   output_chunked' ?buf (IO.Output.of_out_channel oc) self
+  *)

src/core/stream.mli.tmp

@@ -64,7 +64,7 @@ val close : t -> unit
 val empty : t
 (** Stream with 0 bytes inside *)
 
-val of_input : ?buf_size:int -> Tiny_httpd_io.Input.t -> t
+val of_input : ?buf_size:int -> Io.Input.t -> t
 (** Make a buffered stream from the given channel.
     @since 0.14 *)
 
@@ -74,10 +74,10 @@ val of_chan : ?buf_size:int -> in_channel -> t
 val of_chan_close_noerr : ?buf_size:int -> in_channel -> t
 (** Same as {!of_chan} but the [close] method will never fail. *)
 
-val of_fd : ?buf_size:int -> Unix.file_descr -> t
+val of_fd : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t
 (** Make a buffered stream from the given file descriptor. *)
 
-val of_fd_close_noerr : ?buf_size:int -> Unix.file_descr -> t
+val of_fd_close_noerr : ?buf_size:int -> closed:bool ref -> Unix.file_descr -> t
 (** Same as {!of_fd} but the [close] method will never fail. *)
 
 val of_bytes : ?i:int -> ?len:int -> bytes -> t

src/core/util.ml

@@ -5,13 +5,18 @@ let percent_encode ?(skip = fun _ -> false) s =
       | c when skip c -> Buffer.add_char buf c
       | ( ' ' | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '(' | ')' | '*' | '+'
         | ',' | '/' | ':' | ';' | '=' | '?' | '@' | '[' | ']' | '~' ) as c ->
-        Printf.bprintf buf "%%%X" (Char.code c)
-      | c when Char.code c > 127 -> Printf.bprintf buf "%%%X" (Char.code c)
+        Printf.bprintf buf "%%%02X" (Char.code c)
+      | c when Char.code c < 32 || Char.code c > 127 ->
+        Printf.bprintf buf "%%%02X" (Char.code c)
       | c -> Buffer.add_char buf c)
     s;
   Buffer.contents buf
 
-let hex_int (s : string) : int = Scanf.sscanf s "%x" (fun x -> x)
+let int_of_hex_nibble = function
+  | '0' .. '9' as c -> Char.code c - Char.code '0'
+  | 'a' .. 'f' as c -> 10 + Char.code c - Char.code 'a'
+  | 'A' .. 'F' as c -> 10 + Char.code c - Char.code 'A'
+  | _ -> invalid_arg "string: invalid hex"
 
 let percent_decode (s : string) : _ option =
   let buf = Buffer.create (String.length s) in
@@ -21,7 +26,10 @@ let percent_decode (s : string) : _ option =
       match String.get s !i with
       | '%' ->
         if !i + 2 < String.length s then (
-          (match hex_int @@ String.sub s (!i + 1) 2 with
+          (match
+             (int_of_hex_nibble (String.get s (!i + 1)) lsl 4)
+             + int_of_hex_nibble (String.get s (!i + 2))
+           with
           | n -> Buffer.add_char buf (Char.chr n)
           | exception _ -> raise Exit);
           i := !i + 3
@@ -69,6 +77,12 @@ let split_on_slash s : _ list =
   List.rev !l
 
 let parse_query s : (_ list, string) result =
+  let s =
+    (* skip hash if present *)
+    match String.index_opt s '#' with
+    | Some i -> String.sub s (i + 1) (String.length s - i - 1)
+    | None -> s
+  in
   let pairs = ref [] in
   let is_sep_ = function
     | '&' | ';' -> true
@@ -107,3 +121,10 @@ let parse_query s : (_ list, string) result =
   | Invalid_argument _ | Not_found | Failure _ ->
     Error (Printf.sprintf "error in parse_query for %S: i=%d,j=%d" s !i !j)
   | Invalid_query -> Error ("invalid query string: " ^ s)
+
+let show_sockaddr = function
+  | Unix.ADDR_UNIX f -> f
+  | Unix.ADDR_INET (inet, port) ->
+    Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet) port
+
+let is_ipv6_str addr : bool = String.contains addr ':'

src/core/util.mli

@@ -34,3 +34,11 @@ val parse_query : string -> ((string * string) list, string) result
     The order might not be preserved.
     @since 0.3
 *)
+
+val show_sockaddr : Unix.sockaddr -> string
+(** Simple printer for socket addresses.
+    @since 0.17 *)
+
+val is_ipv6_str : string -> bool
+(** Is this string potentially an IPV6 address?
+    @since 0.17 *)

src/dune

@@ -1,29 +1,12 @@
-
-(env
- (_
-  (flags :standard -warn-error -a+8 -w +a-4-32-40-42-44-48-70 -color always -safe-string
-    -strict-sequence)))
-
 (library
-  (name tiny_httpd)
-  (public_name tiny_httpd)
-  (libraries threads seq)
-  (wrapped false))
-
-(rule
- (targets Tiny_httpd_html_.ml)
- (deps
-  (:bin ./gen/gentags.exe))
- (action
-  (with-stdout-to
-   %{targets}
-   (run %{bin}))))
-
-(rule
- (targets Tiny_httpd_atomic_.ml)
- (deps
-  (:bin ./gen/mkshims.exe))
- (action
-  (with-stdout-to
-   %{targets}
-   (run %{bin}))))
+ (name tiny_httpd)
+ (public_name tiny_httpd)
+ (flags :standard -open Tiny_httpd_core)
+ (libraries
+  threads
+  seq
+  unix
+  hmap
+  (re_export tiny_httpd.core)
+  (re_export tiny_httpd.html)
+  (re_export tiny_httpd.unix)))

src/gen/dune

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

src/html/Tiny_httpd_html.ml

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

src/html/dune

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

src/html/gen/dune

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

src/html/gen/gentags.ml

@@ -1,7 +1,6 @@
 (* adapted from https://github.com/sindresorhus/html-tags (MIT licensed) *)
 
 let pf = Printf.printf
-let spf = Printf.sprintf
 
 let void =
   [
@@ -294,14 +293,13 @@ let prelude =
 module Out : sig
   type t
   val create_of_buffer : Buffer.t -> t
-  val create_of_out: Tiny_httpd_io.Output.t -> t
+  val create_of_out: IO.Output.t -> t
   val flush : t -> unit
   val add_char : t -> char -> unit
   val add_string : t -> string -> unit
   val add_format_nl : t -> unit
   val with_no_format_nl : t -> (unit -> 'a) -> 'a
 end = struct
-  module IO = Tiny_httpd_io
   type t = {
     out: IO.Output.t;
     mutable fmt_nl: bool; (* if true, we print [\n] around tags to format the html *)

src/multipart_form/content_disposition.ml

@@ -0,0 +1,31 @@
+open Utils_
+
+type t = { kind: string; name: string option; filename: string option }
+
+(** Simple display *)
+let to_string (self : t) =
+  let stropt = function
+    | None -> "None"
+    | Some s -> spf "%S" s
+  in
+  spf "{kind=%S; name=%s; filename=%s}" self.kind (stropt self.name)
+    (stropt self.filename)
+
+let parse (hs : Tiny_httpd.Headers.t) : t option =
+  match Tiny_httpd.Headers.get "content-disposition" hs with
+  | None -> None
+  | Some s ->
+    (match String.split_on_char ';' s with
+    | [] ->
+      failwith (Printf.sprintf "multipart: invalid content-disposition %S" s)
+    | kind :: tl ->
+      let name = ref None in
+      let filename = ref None in
+      List.iter
+        (fun s ->
+          match Utils_.split1_on ~c:'=' @@ String.trim s with
+          | Some ("name", v) -> name := Some (Utils_.remove_quotes v)
+          | Some ("filename", v) -> filename := Some (Utils_.remove_quotes v)
+          | _ -> ())
+        tl;
+      Some { kind; name = !name; filename = !filename })

src/multipart_form/dune

@@ -0,0 +1,5 @@
+(library
+ (name tiny_httpd_multipart_form_data)
+ (public_name tiny_httpd.multipart-form-data)
+ (synopsis "Port of multipart-form-data for tiny_httpd")
+ (libraries iostream tiny_httpd))

src/multipart_form/tiny_httpd_multipart_form_data.ml

@@ -0,0 +1,250 @@
+(* ported from https://github.com/cryptosense/multipart-form-data . *)
+
+open Tiny_httpd
+module Slice = Iostream.Slice
+module Content_disposition = Content_disposition
+
+let spf = Printf.sprintf
+
+type buf = { bs: bytes; mutable len: int }
+
+let shift_left_ (self : buf) n =
+  if n = self.len then
+    self.len <- 0
+  else (
+    assert (n < self.len);
+    Bytes.blit self.bs n self.bs 0 (self.len - n);
+    self.len <- self.len - n
+  )
+
+let[@inline] buf_full (self : buf) : bool = self.len >= Bytes.length self.bs
+
+type slice = Iostream.Slice.t
+type event = Part of Tiny_httpd.Headers.t | Read of slice | End_of_input
+type out_state = Begin | Inside_part | Eof
+
+type st = {
+  boundary: string;
+  ic: Iostream.In.t;
+  buf: buf;  (** Used to split on the boundary *)
+  mutable first: bool;  (** Are we parsing the first boundary? *)
+  mutable eof_split: bool;
+  buf_out: buf;  (** Used to return output slices *)
+  mutable st_out: out_state;
+}
+
+let create ?(buf_size = 64 * 1024) ?(out_buf_size = 8 * 1024) ~boundary ic : st
+    =
+  let ic = (ic : #Iostream.In.t :> Iostream.In.t) in
+  {
+    boundary;
+    first = true;
+    ic;
+    buf = { bs = Bytes.create buf_size; len = 0 };
+    eof_split = false;
+    buf_out = { bs = Bytes.create out_buf_size; len = 0 };
+    st_out = Begin;
+  }
+
+type chunk = Delim | Eof | Read of int
+
+let[@inline] prefix_size_ (self : st) : int =
+  if self.first then
+    2
+  else
+    4
+
+let[@inline] min_len_ (self : st) : int =
+  prefix_size_ self + String.length self.boundary
+
+exception Found_boundary of int
+
+let rec read_chunk_ (self : st) buf i_buf len : chunk =
+  if self.eof_split then
+    Eof
+  else if self.buf.len < min_len_ self then (
+    (* try to refill buffer *)
+    let n =
+      Iostream.In.input self.ic self.buf.bs self.buf.len
+        (Bytes.length self.buf.bs - self.buf.len)
+    in
+    if n = 0 && self.buf.len = 0 then (
+      self.eof_split <- true;
+      Eof
+    ) else if n = 0 then (
+      let n_read = min len self.buf.len in
+      Bytes.blit self.buf.bs 0 buf i_buf n_read;
+      shift_left_ self.buf n_read;
+      Read n_read
+    ) else (
+      self.buf.len <- self.buf.len + n;
+      read_chunk_ self buf i_buf len
+    )
+  ) else (
+    try
+      let i = ref 0 in
+      let end_pos =
+        min len self.buf.len - prefix_size_ self - String.length self.boundary
+      in
+      while !i <= end_pos do
+        if
+          self.first
+          && Bytes.unsafe_get self.buf.bs !i = '-'
+          && Bytes.unsafe_get self.buf.bs (!i + 1) = '-'
+          && Utils_.string_eq
+               ~a:(Bytes.unsafe_to_string self.buf.bs)
+               ~a_start:(!i + 2) ~b:self.boundary
+               ~len:(String.length self.boundary)
+          || (not self.first)
+             && Bytes.unsafe_get self.buf.bs !i = '\r'
+             && Bytes.unsafe_get self.buf.bs (!i + 1) = '\n'
+             && Bytes.unsafe_get self.buf.bs (!i + 2) = '-'
+             && Bytes.unsafe_get self.buf.bs (!i + 3) = '-'
+             && Utils_.string_eq
+                  ~a:(Bytes.unsafe_to_string self.buf.bs)
+                  ~a_start:(!i + 4) ~b:self.boundary
+                  ~len:(String.length self.boundary)
+        then
+          raise_notrace (Found_boundary !i);
+        incr i
+      done;
+      let n_read = min !i len in
+      Bytes.blit self.buf.bs 0 buf i_buf n_read;
+      shift_left_ self.buf n_read;
+      Read n_read
+    with
+    | Found_boundary 0 ->
+      shift_left_ self.buf (prefix_size_ self + String.length self.boundary);
+      self.first <- false;
+      Delim
+    | Found_boundary n ->
+      let n_read = min n len in
+      Bytes.blit self.buf.bs 0 buf i_buf n_read;
+      shift_left_ self.buf n_read;
+      Read n_read
+  )
+
+exception Found of int
+
+(** Find \r\n *)
+let find_crlf_exn (buf : buf) : int =
+  try
+    for i = 0 to buf.len - 2 do
+      if
+        Bytes.unsafe_get buf.bs i = '\r'
+        && Bytes.unsafe_get buf.bs (i + 1) = '\n'
+      then
+        raise_notrace (Found i)
+    done;
+    raise Not_found
+  with Found i -> i
+
+let[@inline] read_to_buf_out_ (self : st) =
+  assert (not (buf_full self.buf_out));
+  read_chunk_ self self.buf_out.bs self.buf_out.len
+    (Bytes.length self.buf_out.bs - self.buf_out.len)
+
+let read_data_or_fail_ (self : st) : unit =
+  match read_to_buf_out_ self with
+  | Delim -> failwith "multipart: unexpected boundary while parsing headers"
+  | Eof -> failwith "multipart: unexpected EOF while parsing headers"
+  | Read n -> self.buf_out.len <- self.buf_out.len + n
+
+let rec next (self : st) : event =
+  match self.st_out with
+  | Eof -> End_of_input
+  | Inside_part when self.buf_out.len > 0 ->
+    (* there's data to return *)
+    let sl =
+      { Slice.bytes = self.buf_out.bs; off = 0; len = self.buf_out.len }
+    in
+    self.buf_out.len <- 0;
+    Read sl
+  | Inside_part ->
+    (* refill or reach boundary *)
+    (match read_to_buf_out_ self with
+    | Eof ->
+      self.st_out <- Eof;
+      End_of_input
+    | Delim -> parse_after_boundary self
+    | Read n ->
+      self.buf_out.len <- n;
+      next self)
+  | Begin ->
+    (match read_to_buf_out_ self with
+    | Delim -> parse_after_boundary self
+    | Eof ->
+      self.st_out <- Eof;
+      End_of_input
+    | Read _ -> failwith "multipart: expected boundary, got data")
+
+and parse_after_boundary (self : st) : event =
+  while self.buf_out.len < 2 do
+    read_data_or_fail_ self
+  done;
+
+  let after_boundary = Bytes.sub_string self.buf_out.bs 0 2 in
+  shift_left_ self.buf_out 2;
+  match after_boundary with
+  | "--" ->
+    self.st_out <- Eof;
+    End_of_input
+  | "\r\n" ->
+    let headers = parse_headers_rec self [] in
+    self.st_out <- Inside_part;
+    Part headers
+  | s ->
+    failwith (spf "multipart: expect '--' or '\r\n' after boundary, got %S" s)
+
+and parse_headers_rec (self : st) acc : Headers.t =
+  if self.buf_out.len = 0 then (
+    read_data_or_fail_ self;
+    parse_headers_rec self acc
+  ) else (
+    match find_crlf_exn self.buf_out with
+    | exception Not_found ->
+      if buf_full self.buf_out then
+        failwith "multipart: header line is too long"
+      else (
+        read_data_or_fail_ self;
+        parse_headers_rec self acc
+      )
+    | i ->
+      let line = Bytes.sub_string self.buf_out.bs 0 i in
+      shift_left_ self.buf_out (i + 2);
+      if line = "" then
+        List.rev acc
+      else (
+        match Tiny_httpd.Headers.parse_line_ line with
+        | Ok (k, v) ->
+          parse_headers_rec self ((String.lowercase_ascii k, v) :: acc)
+        | Error msg ->
+          failwith
+            (spf "multipart: failed to parser header: %s\nline: %S" msg line)
+      )
+  )
+
+let parse_content_type (hs : Tiny_httpd.Headers.t) : _ option =
+  match Tiny_httpd.Headers.get "content-type" hs with
+  | None -> None
+  | Some s ->
+    (match String.split_on_char ';' s with
+    | "multipart/form-data" :: tl ->
+      let boundary = ref None in
+      List.iter
+        (fun s ->
+          match Utils_.split1_on ~c:'=' @@ String.trim s with
+          | Some ("boundary", "") -> ()
+          | Some ("boundary", s) ->
+            let s = Utils_.remove_quotes s in
+            boundary := Some (`boundary s)
+          | _ -> ())
+        tl;
+      !boundary
+    | _ -> None)
+
+module Private_ = struct
+  type nonrec chunk = chunk = Delim | Eof | Read of int
+
+  let read_chunk_ = read_chunk_
+end

src/multipart_form/tiny_httpd_multipart_form_data.mli

@@ -0,0 +1,25 @@
+(** Streaming parser for multipart/form-data *)
+
+module Content_disposition = Content_disposition
+
+type st
+(** Parser state *)
+
+val create :
+  ?buf_size:int -> ?out_buf_size:int -> boundary:string -> #Iostream.In.t -> st
+
+val parse_content_type : Tiny_httpd.Headers.t -> [ `boundary of string ] option
+(** Parse headers for [content-type: multipart/form-data; boundary=…] *)
+
+type slice = Iostream.Slice.t
+type event = Part of Tiny_httpd.Headers.t | Read of slice | End_of_input
+
+val next : st -> event
+
+(**/*)
+module Private_ : sig
+  type chunk = Delim | Eof | Read of int
+
+  val read_chunk_ : st -> bytes -> int -> int -> chunk
+end
+(**/*)

src/multipart_form/utils_.ml

@@ -0,0 +1,28 @@
+let spf = Printf.sprintf
+
+let string_eq ~a ~a_start ~b ~len : bool =
+  assert (len <= String.length b);
+  if String.length a >= a_start + len then (
+    try
+      for i = 0 to len - 1 do
+        let a_i = a_start + i in
+        if String.unsafe_get a a_i <> String.unsafe_get b i then
+          raise_notrace Exit
+      done;
+      true
+    with Exit -> false
+  ) else
+    false
+
+let split1_on ~c s =
+  match String.index s c with
+  | exception Not_found -> None
+  | i -> Some (String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1))
+
+let remove_quotes s : string =
+  if String.length s < 2 then
+    s
+  else if s.[0] = '"' && s.[String.length s - 1] = '"' then
+    String.sub s 1 (String.length s - 2)
+  else
+    s

src/prometheus/common_p_.ml

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

src/prometheus/dune

@@ -0,0 +1,14 @@
+(library
+ (name tiny_httpd_prometheus)
+ (public_name tiny_httpd.prometheus)
+ (synopsis "Metrics using prometheus")
+ (private_modules common_p_ time_)
+ (flags :standard -open Tiny_httpd_core)
+ (libraries
+  (re_export tiny_httpd.core)
+  unix
+  (select
+   time_.ml
+   from
+   (mtime mtime.clock.os -> time_.mtime.ml)
+   (-> time_.default.ml))))

src/prometheus/time_.default.ml

@@ -0,0 +1,3 @@
+let[@inline] now_us () =
+  let t = Unix.gettimeofday () in
+  t *. 1e6 |> ceil

src/prometheus/time_.mli

@@ -0,0 +1 @@
+val now_us : unit -> float

src/prometheus/time_.mtime.ml

@@ -0,0 +1,3 @@
+let[@inline] now_us () =
+  let t = Mtime_clock.now_ns () in
+  Int64.(div t 1000L |> to_float)

src/prometheus/tiny_httpd_prometheus.ml

@@ -0,0 +1,241 @@
+(*
+  https://prometheus.io/docs/instrumenting/exposition_formats/#text-based-format
+  *)
+
+open Common_p_
+
+let bpf = Printf.bprintf
+
+type tags = (string * string) list
+type counter = { name: string; tags: tags; descr: string option; c: int A.t }
+type gauge = { name: string; tags: tags; descr: string option; g: int A.t }
+
+type histogram = {
+  name: string;
+  tags: tags;
+  descr: string option;
+  sum: float A.t;
+  buckets: (float * int A.t) array;
+}
+
+type registry = {
+  mutable counters: counter list;
+  mutable gauges: gauge list;
+  mutable hists: histogram list;
+  mutable on_will_emit: (unit -> unit) list;
+}
+
+let validate_descr_ what s =
+  if String.contains s '\n' then
+    invalid_arg (spf "%s: description cannot contain '\n'" what)
+
+let emit_tags_ buf tags =
+  if tags <> [] then (
+    bpf buf "{";
+    List.iteri
+      (fun i (k, v) ->
+        if i > 0 then bpf buf ",";
+        bpf buf "%s=%S" k v)
+      tags;
+    bpf buf "}"
+  )
+
+let opt_iter_ f = function
+  | None -> ()
+  | Some x -> f x
+
+module Counter = struct
+  type t = counter
+
+  let create (reg : registry) ?(tags = []) ?descr name : t =
+    let self : t = { name; descr; tags; c = A.make 0 } in
+    opt_iter_ (validate_descr_ "counter") descr;
+    reg.counters <- self :: reg.counters;
+    self
+
+  let emit buf (self : t) =
+    opt_iter_ (bpf buf "# HELP %s %s\n" self.name) self.descr;
+    bpf buf "# TYPE %s counter\n" self.name;
+    bpf buf "%s%a %d\n" self.name emit_tags_ self.tags (A.get self.c);
+    ()
+
+  let[@inline] incr self = A.incr self.c
+  let[@inline] incr_by self n = ignore (A.fetch_and_add self.c n : int)
+
+  let incr_to self n =
+    while
+      let old = A.get self.c in
+      if old < n then
+        not (A.compare_and_set self.c old n)
+      else
+        false
+    do
+      ()
+    done
+end
+
+module Gauge = struct
+  type t = gauge
+
+  let create (reg : registry) ?(tags = []) ?descr name : t =
+    opt_iter_ (validate_descr_ "gauge") descr;
+    let self : t = { name; descr; tags; g = A.make 0 } in
+    reg.gauges <- self :: reg.gauges;
+    self
+
+  let emit buf (self : t) =
+    opt_iter_ (bpf buf "# HELP %s %s\n" self.name) self.descr;
+    bpf buf "# TYPE %s gauge\n" self.name;
+    bpf buf "%s%a %d\n" self.name emit_tags_ self.tags (A.get self.g);
+    ()
+
+  let[@inline] set self x = A.set self.g x
+  let[@inline] incr self = A.incr self.g
+  let[@inline] incr_by self n = ignore (A.fetch_and_add self.g n : int)
+  let[@inline] decr self = A.decr self.g
+  let[@inline] decr_by self n = ignore (A.fetch_and_add self.g (-n) : int)
+end
+
+module Histogram = struct
+  type t = histogram
+
+  let create reg ?(tags = []) ?descr ~buckets name : t =
+    opt_iter_ (validate_descr_ "histogram") descr;
+    let buckets =
+      List.sort Stdlib.compare buckets
+      |> List.map (fun thresh -> thresh, A.make 0)
+    in
+    let buckets = Array.of_list @@ buckets @ [ infinity, A.make 0 ] in
+    let self : t = { name; descr; tags; sum = A.make 0.; buckets } in
+    reg.hists <- self :: reg.hists;
+    self
+
+  let add (self : t) n =
+    while
+      let old = A.get self.sum in
+      not (A.compare_and_set self.sum old (old +. n))
+    do
+      ()
+    done;
+    let i = ref 0 in
+    let continue = ref true in
+    while !continue && !i < Array.length self.buckets do
+      let thresh, count = self.buckets.(!i) in
+      if n <= thresh then (
+        continue := false;
+        A.incr count
+      ) else
+        incr i
+    done
+
+  let emit buf (self : t) : unit =
+    opt_iter_ (bpf buf "# HELP %s %s\n" self.name) self.descr;
+    bpf buf "# TYPE %s histogram\n" self.name;
+
+    let count = ref 0 in
+    for i = 0 to Array.length self.buckets - 1 do
+      let thresh, buck_count = self.buckets.(i) in
+      count := !count + A.get buck_count;
+
+      let name =
+        if thresh = infinity then
+          "+Inf"
+        else
+          string_of_float thresh
+      in
+      bpf buf "%s_bucket%a %d\n" self.name emit_tags_
+        (("le", name) :: self.tags)
+        !count
+    done;
+    bpf buf "%s_count%a %d\n" self.name emit_tags_ self.tags !count;
+    bpf buf "%s_sum%a %.3f\n" self.name emit_tags_ self.tags (A.get self.sum);
+    ()
+end
+
+module Registry = struct
+  type t = registry
+
+  let create () : t =
+    { counters = []; gauges = []; hists = []; on_will_emit = [] }
+
+  let on_will_emit self f = self.on_will_emit <- f :: self.on_will_emit
+
+  let emit (buf : Buffer.t) (self : t) : unit =
+    List.iter (fun f -> f ()) self.on_will_emit;
+    List.iter (Gauge.emit buf) self.gauges;
+    List.iter (Counter.emit buf) self.counters;
+    List.iter (Histogram.emit buf) self.hists;
+    ()
+
+  let emit_str (self : t) : string =
+    let buf = Buffer.create 32 in
+    emit buf self;
+    Buffer.contents buf
+end
+
+let global = Registry.create ()
+
+let http_middleware (reg : Registry.t) : Server.Middleware.t =
+  let c_req =
+    Counter.create reg "tiny_httpd_requests" ~descr:"number of HTTP requests"
+  in
+  let c_err =
+    Counter.create reg "tiny_httpd_errors" ~descr:"number of HTTP errors"
+  in
+  let h_latency =
+    Histogram.create reg "tiny_httpd_latency" ~descr:"latency of HTTP responses"
+      ~buckets:[ 0.001; 0.01; 0.1; 0.5; 1.; 5.; 10. ]
+  in
+
+  fun h : Server.Middleware.handler ->
+    fun req ~resp : unit ->
+     let start = Time_.now_us () in
+     Counter.incr c_req;
+     h req ~resp:(fun (response : Response.t) ->
+         let code = response.code in
+
+         let elapsed_us = Time_.now_us () -. start in
+         let elapsed_s = elapsed_us /. 1e6 in
+         Histogram.add h_latency elapsed_s;
+
+         if code < 200 || code >= 400 then Counter.incr c_err;
+         resp response)
+
+let add_route_to_server (server : Server.t) (reg : registry) : unit =
+  Server.add_route_handler server Route.(exact "metrics" @/ return)
+  @@ fun _req ->
+  let str = Registry.emit_str reg in
+  (* https://prometheus.io/docs/instrumenting/exposition_formats/#text-based-format *)
+  let headers = [ "content-type", "text/plain; version=0.0.4" ] in
+  Response.make_string ~headers @@ Ok str
+
+let instrument_server (server : Server.t) reg : unit =
+  Server.add_middleware ~stage:(`Stage 1) server (http_middleware reg);
+  add_route_to_server server reg
+
+module GC_metrics = struct
+  type t = { major_coll: counter; major_heap: gauge; compactions: counter }
+
+  let create reg : t =
+    let major_coll =
+      Counter.create reg ~descr:"major GC collections" "ocaml_gc_major"
+    in
+    let major_heap =
+      Gauge.create reg ~descr:"size of major heap" "ocaml_gc_major_heap_size"
+    in
+    let compactions =
+      Counter.create reg ~descr:"number of GC compactions"
+        "ocaml_gc_compactions"
+    in
+    { major_coll; major_heap; compactions }
+
+  let update (self : t) =
+    let stats = Gc.quick_stat () in
+    Counter.incr_to self.major_coll stats.major_collections;
+    Counter.incr_to self.compactions stats.compactions;
+    Gauge.set self.major_heap (stats.heap_words * 8)
+
+  let create_and_update_before_emit reg : unit =
+    let gc = create reg in
+    Registry.on_will_emit reg (fun () -> update gc)
+end

src/prometheus/tiny_httpd_prometheus.mli

@@ -0,0 +1,94 @@
+(** 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.
+
+ @since 0.16
+ *)
+
+type tags = (string * string) list
+
+(** Registry for metrics. *)
+module Registry : sig
+  type t
+  (** The registry contains a group of metrics *)
+
+  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. *)
+
+  val emit : Buffer.t -> t -> unit
+  (** Write metrics into the given buffer. The buffer will be
+      cleared first thing. *)
+
+  val emit_str : t -> string
+end
+
+val global : Registry.t
+
+(** Counters *)
+module Counter : sig
+  type t
+  (** A counter, monotonically increasing *)
+
+  val create : Registry.t -> ?tags:tags -> ?descr:string -> string -> t
+  val incr : t -> unit
+  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 *)
+end
+
+(** Gauges *)
+module Gauge : sig
+  type t
+  (** A gauge, taking arbitrary values *)
+
+  val create : Registry.t -> ?tags:tags -> ?descr:string -> string -> t
+  val set : t -> int -> unit
+  val incr : t -> unit
+  val incr_by : t -> int -> unit
+  val decr : t -> unit
+  val decr_by : t -> int -> unit
+end
+
+module Histogram : sig
+  type t
+  (** Histogram *)
+
+  val create :
+    Registry.t ->
+    ?tags:tags ->
+    ?descr:string ->
+    buckets:float list ->
+    string ->
+    t
+
+  val add : t -> float -> unit
+end
+
+val http_middleware : Registry.t -> Server.Middleware.t
+(** Middleware to get basic metrics about HTTP requests *)
+
+val add_route_to_server : Server.t -> Registry.t -> unit
+(** Add a "/metrics" route to the server *)
+
+val instrument_server : Server.t -> Registry.t -> unit
+(** Add middleware and route *)
+
+module GC_metrics : sig
+  type t
+
+  val create : Registry.t -> t
+  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. *)
+end

src/unix/dir.ml

@@ -1,6 +1,7 @@
-module S = Tiny_httpd_server
-module U = Tiny_httpd_util
+module S = Server
+module U = Util
 module Html = Tiny_httpd_html
+module Log = Log
 
 type dir_behavior = Index | Lists | Index_or_lists | Forbidden
 type hidden = unit
@@ -77,7 +78,7 @@ module type VFS = sig
   val list_dir : string -> string array
   val delete : string -> unit
   val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
-  val read_file_content : string -> Tiny_httpd_stream.t
+  val read_file_content : string -> IO.Input.t
   val file_size : string -> int option
   val file_mtime : string -> float option
 end
@@ -93,8 +94,14 @@ let vfs_of_dir (top : string) : vfs =
     let list_dir f = Sys.readdir (top // f)
 
     let read_file_content f =
-      let ic = Unix.(openfile (top // f) [ O_RDONLY ] 0) in
-      Tiny_httpd_stream.of_fd ic
+      let fpath = top // f in
+      match Unix.stat fpath with
+      | { st_kind = Unix.S_REG; _ } ->
+        let ic = Unix.(openfile fpath [ O_RDONLY ] 0) in
+        let closed = ref false in
+        let buf = IO.Slice.create 4096 in
+        IO.Input.of_unix_fd ~buf ~close_noerr:true ~closed ic
+      | _ -> failwith (Printf.sprintf "not a regular file: %S" f)
 
     let create f =
       let oc = open_out_bin (top // f) in
@@ -196,87 +203,78 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt =
   in
   html [] [ head; body ]
 
-let finally_ ~h x f =
-  try
-    let y = f x in
-    h x;
-    y
-  with e ->
-    h x;
-    raise e
-
 (* @param on_fs: if true, we assume the file exists on the FS *)
 let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
     : unit =
   let route () =
     if prefix = "" then
-      S.Route.rest_of_path_urlencoded
+      Route.rest_of_path_urlencoded
     else
-      S.Route.exact_path prefix S.Route.rest_of_path_urlencoded
+      Route.exact_path prefix Route.rest_of_path_urlencoded
   in
   if config.delete then
     S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req ->
         if contains_dot_dot path then
-          S.Response.fail_raise ~code:403 "invalid path in delete"
+          Response.fail_raise ~code:403 "invalid path in delete"
         else
-          S.Response.make_string
+          Response.make_string
             (try
                VFS.delete path;
                Ok "file deleted successfully"
              with e -> Error (500, Printexc.to_string e)))
   else
     S.add_route_handler server ~meth:`DELETE (route ()) (fun _ _ ->
-        S.Response.make_raw ~code:405 "delete not allowed");
+        Response.make_raw ~code:405 "delete not allowed");
 
   if config.upload then
     S.add_route_handler_stream server ~meth:`PUT (route ())
       ~accept:(fun req ->
-        match S.Request.get_header_int req "Content-Length" with
+        match Request.get_header_int req "Content-Length" with
         | Some n when n > config.max_upload_size ->
           Error
             (403, "max upload size is " ^ string_of_int config.max_upload_size)
-        | Some _ when contains_dot_dot req.S.Request.path ->
+        | Some _ when contains_dot_dot req.Request.path ->
           Error (403, "invalid path (contains '..')")
         | _ -> Ok ())
       (fun path req ->
         let write, close =
           try VFS.create path
           with e ->
-            S.Response.fail_raise ~code:403 "cannot upload to %S: %s" path
+            Response.fail_raise ~code:403 "cannot upload to %S: %s" path
               (Printexc.to_string e)
         in
         let req =
-          S.Request.limit_body_size ~max_size:config.max_upload_size req
+          Request.limit_body_size ~bytes:(Bytes.create 4096)
+            ~max_size:config.max_upload_size req
         in
-        Tiny_httpd_stream.iter write req.S.Request.body;
+        IO.Input.iter write req.body;
         close ();
-        S._debug (fun k -> k "done uploading");
-        S.Response.make_raw ~code:201 "upload successful")
+        Log.debug (fun k -> k "dir: done uploading file to %S" path);
+        Response.make_raw ~code:201 "upload successful")
   else
     S.add_route_handler server ~meth:`PUT (route ()) (fun _ _ ->
-        S.Response.make_raw ~code:405 "upload not allowed");
+        Response.make_raw ~code:405 "upload not allowed");
 
   if config.download then
     S.add_route_handler server ~meth:`GET (route ()) (fun path req ->
-        S._debug (fun k -> k "path=%S" path);
+        Log.debug (fun k -> k "dir: download path=%S" path);
         let mtime =
           lazy
             (match VFS.file_mtime path with
-            | None -> S.Response.fail_raise ~code:403 "Cannot access file"
+            | None -> Response.fail_raise ~code:403 "Cannot access file"
             | Some t -> Printf.sprintf "mtime: %.4f" t)
         in
         if contains_dot_dot path then
-          S.Response.fail ~code:403 "Path is forbidden"
+          Response.fail ~code:403 "Path is forbidden"
         else if not (VFS.contains path) then
-          S.Response.fail ~code:404 "File not found"
-        else if
-          S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
+          Response.fail ~code:404 "File not found"
+        else if Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
         then (
-          S._debug (fun k ->
-              k "cached object %S (etag: %S)" path (Lazy.force mtime));
-          S.Response.make_raw ~code:304 ""
+          Log.debug (fun k ->
+              k "dir: cached object %S (etag: %S)" path (Lazy.force mtime));
+          Response.make_raw ~code:304 ""
         ) else if VFS.is_directory path then (
-          S._debug (fun k -> k "list dir %S (topdir %S)" path VFS.descr);
+          Log.debug (fun k -> k "dir: list dir %S (topdir %S)" path VFS.descr);
           let parent = Filename.(dirname path) in
           let parent =
             if Filename.basename path <> "." then
@@ -288,53 +286,50 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
           | (Index | Index_or_lists) when VFS.contains (path // "index.html") ->
             (* redirect using path, not full path *)
             let new_path = "/" // prefix // path // "index.html" in
-            S._debug (fun k -> k "redirect to `%s`" new_path);
-            S.Response.make_void ~code:301 ()
-              ~headers:S.Headers.(empty |> set "location" new_path)
+            Log.debug (fun k -> k "dir: redirect to `%s`" new_path);
+            Response.make_void ~code:301 ()
+              ~headers:Headers.(empty |> set "location" new_path)
           | Lists | Index_or_lists ->
             let body =
               html_list_dir ~prefix vfs path ~parent |> Html.to_string_top
             in
-            S.Response.make_string
+            Response.make_string
               ~headers:[ header_html; "ETag", Lazy.force mtime ]
               (Ok body)
           | Forbidden | Index ->
-            S.Response.make_raw ~code:405 "listing dir not allowed"
+            Response.make_raw ~code:405 "listing dir not allowed"
         ) else (
           try
             let mime_type =
-              if Filename.extension path = ".css" then
+              (* FIXME: handle .html specially *)
+              if Filename.extension path = ".html" then
+                [ "Content-Type", "text/html" ]
+              else if Filename.extension path = ".css" then
                 [ "Content-Type", "text/css" ]
               else if Filename.extension path = ".js" then
                 [ "Content-Type", "text/javascript" ]
               else if on_fs then (
                 (* call "file" util *)
-                try
-                  let p =
-                    Unix.open_process_in
-                      (Printf.sprintf "file -i -b %S" (top // path))
-                  in
-                  finally_
-                    ~h:(fun p -> ignore @@ Unix.close_process_in p)
-                    p
-                    (fun p ->
-                      try [ "Content-Type", String.trim (input_line p) ]
-                      with _ -> [])
-                with _ -> []
+                let ty = Mime_.mime_of_path (top // path) in
+                [ "content-type", ty ]
               ) else
                 []
             in
             let stream = VFS.read_file_content path in
-            S.Response.make_raw_stream
+            Response.make_raw_stream
               ~headers:(mime_type @ [ "Etag", Lazy.force mtime ])
               ~code:200 stream
           with e ->
-            S.Response.fail ~code:500 "error while reading file: %s"
-              (Printexc.to_string e)
+            let bt = Printexc.get_raw_backtrace () in
+            let msg = Printexc.to_string e in
+            Log.error (fun k ->
+                k "dir.get failed: %s@.%s" msg
+                  (Printexc.raw_backtrace_to_string bt));
+            Response.fail ~code:500 "error while reading file: %s" msg
         ))
   else
     S.add_route_handler server ~meth:`GET (route ()) (fun _ _ ->
-        S.Response.make_raw ~code:405 "download not allowed");
+        Response.make_raw ~code:405 "download not allowed");
   ()
 
 let add_vfs ~config ~vfs ~prefix server : unit =
@@ -425,7 +420,7 @@ module Embedded_fs = struct
         | _ -> None
 
       let contains p =
-        S._debug (fun k -> k "contains %S" p);
+        Log.debug (fun k -> k "vfs: contains %S" p);
         match find_ self p with
         | Some _ -> true
         | None -> false
@@ -437,11 +432,11 @@ module Embedded_fs = struct
 
       let read_file_content p =
         match find_ self p with
-        | Some (File { content; _ }) -> Tiny_httpd_stream.of_string content
+        | Some (File { content; _ }) -> IO.Input.of_string content
         | _ -> failwith (Printf.sprintf "no such file: %S" p)
 
       let list_dir p =
-        S._debug (fun k -> k "list dir %S" p);
+        Log.debug (fun k -> k "vfs: list dir %S" p);
         match find_ self p with
         | Some (Dir sub) ->
           Str_map.fold (fun sub _ acc -> sub :: acc) sub.entries []

src/unix/dir.mli

@@ -60,7 +60,7 @@ val config :
     @since 0.12 *)
 
 val add_dir_path :
-  config:config -> dir:string -> prefix:string -> Tiny_httpd_server.t -> unit
+  config:config -> dir:string -> prefix:string -> Server.t -> unit
 (** [add_dirpath ~config ~dir ~prefix server] adds route handle to the
     [server] to serve static files in [dir] when url starts with [prefix],
     using the given configuration [config]. *)
@@ -91,7 +91,7 @@ module type VFS = sig
   val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
   (** Create a file and obtain a pair [write, close] *)
 
-  val read_file_content : string -> Tiny_httpd_stream.t
+  val read_file_content : string -> IO.Input.t
   (** Read content of a file *)
 
   val file_size : string -> int option
@@ -108,11 +108,7 @@ val vfs_of_dir : string -> (module VFS)
 *)
 
 val add_vfs :
-  config:config ->
-  vfs:(module VFS) ->
-  prefix:string ->
-  Tiny_httpd_server.t ->
-  unit
+  config:config -> vfs:(module VFS) -> prefix:string -> Server.t -> unit
 (** Similar to {!add_dir_path} but using a virtual file system instead.
     @since 0.12
 *)

src/unix/dune

@@ -0,0 +1,15 @@
+(library
+ (name tiny_httpd_unix)
+ (public_name tiny_httpd.unix)
+ (synopsis "Backend based on Unix and blocking IOs for Tiny_httpd")
+ (flags :standard -open Tiny_httpd_core)
+ (private_modules mime_)
+ (libraries
+  tiny_httpd.core
+  tiny_httpd.html
+  unix
+  (select
+   mime_.ml
+   from
+   (magic-mime -> mime_.magic.ml)
+   (-> mime_.dummy.ml))))

src/unix/mime_.dummy.ml

@@ -0,0 +1 @@
+let mime_of_path _ = "application/octet-stream"

src/unix/mime_.magic.ml

@@ -0,0 +1 @@
+let mime_of_path s = Magic_mime.lookup s

src/unix/mime_.mli

@@ -0,0 +1 @@
+val mime_of_path : string -> string

src/unix/sem.ml

@@ -0,0 +1,25 @@
+(** semaphore, for limiting concurrency. *)
+
+type t = { mutable n: int; max: int; mutex: Mutex.t; cond: Condition.t }
+
+let create n =
+  if n <= 0 then invalid_arg "Semaphore.create";
+  { n; max = n; mutex = Mutex.create (); cond = Condition.create () }
+
+let acquire m t =
+  Mutex.lock t.mutex;
+  while t.n < m do
+    Condition.wait t.cond t.mutex
+  done;
+  assert (t.n >= m);
+  t.n <- t.n - m;
+  Condition.broadcast t.cond;
+  Mutex.unlock t.mutex
+
+let release m t =
+  Mutex.lock t.mutex;
+  t.n <- t.n + m;
+  Condition.broadcast t.cond;
+  Mutex.unlock t.mutex
+
+let num_acquired t = t.max - t.n

src/unix/tiny_httpd_unix.ml

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

src/ws/common_ws_.ml

@@ -0,0 +1,2 @@
+let spf = Printf.sprintf
+let ( let@ ) = ( @@ )

src/ws/dune

@@ -0,0 +1,38 @@
+; 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))
+ (target optlevel.string)
+ (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))
+ (target optlevel.string)
+ (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))
+ (target cflags.sexp)
+ (action (with-stdout-to %{target} (echo "(%{read:optlevel.string})"))))
+(rule
+ (enabled_if (not (= %{ocaml-config:ccomp_type} msvc)))
+ (target cflags.sexp)
+ (action (with-stdout-to %{target} (echo "(-std=c99 -fPIC %{read:optlevel.string})"))))
+
+(library
+ (name tiny_httpd_ws)
+ (public_name tiny_httpd.ws)
+ (synopsis "Websockets for tiny_httpd")
+ (private_modules common_ws_ utils_)
+ (flags :standard -open Tiny_httpd_core)
+ (foreign_stubs
+  (language c)
+  (names tiny_httpd_ws_stubs)
+  (flags :standard (:include cflags.sexp)))
+ (libraries
+  (re_export tiny_httpd.core)
+  threads))

src/ws/tiny_httpd_ws.ml

@@ -0,0 +1,498 @@
+open Common_ws_
+
+module With_lock = struct
+  type t = { with_lock: 'a. (unit -> 'a) -> 'a }
+  type builder = unit -> t
+
+  let default_builder : builder =
+   fun () ->
+    let mutex = Mutex.create () in
+    {
+      with_lock =
+        (fun f ->
+          Mutex.lock mutex;
+          try
+            let x = f () in
+            Mutex.unlock mutex;
+            x
+          with e ->
+            Mutex.unlock mutex;
+            raise e);
+    }
+end
+
+type handler = unit Request.t -> IO.Input.t -> IO.Output.t -> unit
+
+module Frame_type = struct
+  type t = int
+
+  let continuation : t = 0
+  let text : t = 1
+  let binary : t = 2
+  let close : t = 8
+  let ping : t = 9
+  let pong : t = 10
+
+  let show = function
+    | 0 -> "continuation"
+    | 1 -> "text"
+    | 2 -> "binary"
+    | 8 -> "close"
+    | 9 -> "ping"
+    | 10 -> "pong"
+    | _ty -> spf "unknown frame type %xd" _ty
+end
+
+module Header = struct
+  type t = {
+    mutable fin: bool;
+    mutable ty: Frame_type.t;
+    mutable payload_len: int;
+    mutable mask: bool;
+    mask_key: bytes;  (** len = 4 *)
+  }
+
+  let create () : t =
+    {
+      fin = false;
+      ty = 0;
+      payload_len = 0;
+      mask = false;
+      mask_key = Bytes.create 4;
+    }
+end
+
+exception Close_connection
+(** Raised to close the connection. *)
+
+module Writer = struct
+  type t = {
+    header: Header.t;
+    header_buf: bytes;
+    buf: bytes;  (** bufferize writes *)
+    mutable offset: int;  (** number of bytes already in [buf] *)
+    oc: IO.Output.t;
+    mutable closed: bool;
+    mutex: With_lock.t;
+  }
+
+  let create ?(buf_size = 16 * 1024) ~with_lock ~oc () : t =
+    {
+      header = Header.create ();
+      header_buf = Bytes.create 16;
+      buf = Bytes.create buf_size;
+      offset = 0;
+      oc;
+      closed = false;
+      mutex = with_lock;
+    }
+
+  let[@inline] close self = self.closed <- true
+  let int_of_bool : bool -> int = Obj.magic
+
+  (** Write the frame header to [self.oc] *)
+  let write_header_ (self : t) : unit =
+    let header_len = ref 2 in
+    let b0 =
+      Char.chr ((int_of_bool self.header.fin lsl 7) lor self.header.ty)
+    in
+    Bytes.unsafe_set self.header_buf 0 b0;
+
+    (* we don't mask *)
+    let payload_len = self.header.payload_len in
+    let payload_first_byte =
+      if payload_len < 126 then
+        payload_len
+      else if payload_len < 1 lsl 16 then (
+        Bytes.set_int16_be self.header_buf 2 payload_len;
+        header_len := 4;
+        126
+      ) else (
+        Bytes.set_int64_be self.header_buf 2 (Int64.of_int payload_len);
+        header_len := 10;
+        127
+      )
+    in
+
+    let b1 =
+      Char.chr @@ ((int_of_bool self.header.mask lsl 7) lor payload_first_byte)
+    in
+    Bytes.unsafe_set self.header_buf 1 b1;
+
+    if self.header.mask then (
+      Bytes.blit self.header_buf !header_len self.header.mask_key 0 4;
+      header_len := !header_len + 4
+    );
+
+    (*Log.debug (fun k ->
+        k "websocket: write header ty=%s (%d B)"
+          (Frame_type.show self.header.ty)
+          !header_len);*)
+    IO.Output.output self.oc self.header_buf 0 !header_len;
+    ()
+
+  (** Max fragment size: send 16 kB at a time *)
+  let max_fragment_size = 16 * 1024
+
+  let[@inline never] really_output_buf_ (self : t) =
+    self.header.fin <- true;
+    self.header.ty <- Frame_type.binary;
+    self.header.payload_len <- self.offset;
+    self.header.mask <- false;
+    write_header_ self;
+
+    IO.Output.output self.oc self.buf 0 self.offset;
+    IO.Output.flush self.oc;
+    self.offset <- 0
+
+  let flush_ (self : t) =
+    if self.closed then raise Close_connection;
+    if self.offset > 0 then really_output_buf_ self
+
+  let[@inline] flush_if_full (self : t) : unit =
+    if self.offset = Bytes.length self.buf then really_output_buf_ self
+
+  let send_pong (self : t) : unit =
+    let@ () = self.mutex.with_lock in
+    self.header.fin <- true;
+    self.header.ty <- Frame_type.pong;
+    self.header.payload_len <- 0;
+    self.header.mask <- false;
+    (* only write a header, we don't send a payload at all *)
+    write_header_ self
+
+  let output_char (self : t) c : unit =
+    let@ () = self.mutex.with_lock in
+    let cap = Bytes.length self.buf - self.offset in
+    (* make room for [c] *)
+    if cap = 0 then really_output_buf_ self;
+    Bytes.set self.buf self.offset c;
+    self.offset <- self.offset + 1;
+    (* if [c] made the buffer full, then flush it *)
+    if cap = 1 then really_output_buf_ self
+
+  let output (self : t) buf i len : unit =
+    let@ () = self.mutex.with_lock in
+    let i = ref i in
+    let len = ref len in
+    while !len > 0 do
+      flush_if_full self;
+
+      let n = min !len (Bytes.length self.buf - self.offset) in
+      assert (n > 0);
+
+      Bytes.blit buf !i self.buf self.offset n;
+      self.offset <- self.offset + n;
+
+      i := !i + n;
+      len := !len - n
+    done;
+    flush_if_full self
+
+  let flush self : unit =
+    let@ () = self.mutex.with_lock in
+    flush_ self
+end
+
+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] *)
+    | Close
+
+  type t = {
+    ic: IO.Input.t;
+    writer: Writer.t;  (** Writer, to send "pong" *)
+    header_buf: bytes;  (** small buffer to read frame headers *)
+    small_buf: bytes;  (** Used for control frames *)
+    header: Header.t;
+    last_ty: Frame_type.t;  (** Last frame's type, used for continuation *)
+    mutable state: state;
+  }
+
+  let create ~ic ~(writer : Writer.t) () : t =
+    {
+      ic;
+      header_buf = Bytes.create 8;
+      small_buf = Bytes.create 128;
+      writer;
+      state = Begin;
+      last_ty = 0;
+      header = Header.create ();
+    }
+
+  (** limitation: we only accept frames that are 2^30 bytes long or less *)
+  let max_fragment_size = 1 lsl 30
+
+  (** Read next frame header into [self.header] *)
+  let read_frame_header (self : t) : unit =
+    (* read header *)
+    IO.Input.really_input self.ic self.header_buf 0 2;
+
+    let b0 = Bytes.unsafe_get self.header_buf 0 |> Char.code in
+    let b1 = Bytes.unsafe_get self.header_buf 1 |> Char.code in
+
+    self.header.fin <- b0 land 1 == 1;
+    let ext = (b0 lsr 4) land 0b0111 in
+    if ext <> 0 then (
+      Log.error (fun k -> k "websocket: unknown extension %d, closing" ext);
+      raise Close_connection
+    );
+
+    self.header.ty <- b0 land 0b0000_1111;
+    self.header.mask <- b1 land 0b1000_0000 != 0;
+
+    let payload_len : int =
+      let len = b1 land 0b0111_1111 in
+      if len = 126 then (
+        IO.Input.really_input self.ic self.header_buf 0 2;
+        Bytes.get_uint16_be self.header_buf 0
+      ) else if len = 127 then (
+        IO.Input.really_input self.ic self.header_buf 0 8;
+        let len64 = Bytes.get_int64_be self.header_buf 0 in
+        if Int64.compare len64 (Int64.of_int max_fragment_size) > 0 then (
+          Log.error (fun k ->
+              k "websocket: maximum frame fragment exceeded (%Ld > %d)" len64
+                max_fragment_size);
+          raise Close_connection
+        );
+
+        Int64.to_int len64
+      ) else
+        len
+    in
+    self.header.payload_len <- payload_len;
+
+    if self.header.mask then
+      IO.Input.really_input self.ic self.header.mask_key 0 4;
+
+    (*Log.debug (fun k ->
+        k "websocket: read frame header type=%s payload_len=%d mask=%b"
+          (Frame_type.show self.header.ty)
+          self.header.payload_len self.header.mask);*)
+    ()
+
+  external apply_masking_ :
+    key:bytes -> key_offset:int -> buf:bytes -> int -> int -> unit
+    = "tiny_httpd_ws_apply_masking"
+  [@@noalloc]
+  (** Apply masking to the parsed data *)
+
+  let[@inline] apply_masking ~mask_key ~mask_offset (buf : bytes) off len : unit
+      =
+    assert (
+      Bytes.length mask_key = 4
+      && mask_offset >= 0 && off >= 0
+      && off + len <= Bytes.length buf);
+    apply_masking_ ~key:mask_key ~key_offset:mask_offset ~buf off len
+
+  let read_body_to_string (self : t) : string =
+    let len = self.header.payload_len in
+    let buf = Bytes.create len in
+    IO.Input.really_input self.ic buf 0 len;
+    if self.header.mask then
+      apply_masking ~mask_key:self.header.mask_key ~mask_offset:0 buf 0 len;
+    Bytes.unsafe_to_string buf
+
+  (** Skip bytes of the body *)
+  let skip_body (self : t) : unit =
+    let len = ref self.header.payload_len in
+    while !len > 0 do
+      let n = min !len (Bytes.length self.small_buf) in
+      IO.Input.really_input self.ic self.small_buf 0 n;
+      len := !len - n
+    done
+
+  (** State machine that reads [len] bytes into [buf] *)
+  let rec read_rec (self : t) buf i len : int =
+    match self.state with
+    | Close -> 0
+    | Reading_frame r when r.remaining_bytes = 0 ->
+      self.state <- Begin;
+      read_rec self buf i len
+    | Reading_frame r ->
+      let len = min len r.remaining_bytes in
+      let n = IO.Input.input self.ic buf i len in
+
+      (* apply masking *)
+      if self.header.mask then
+        apply_masking ~mask_key:self.header.mask_key ~mask_offset:r.num_read buf
+          i n
+      else (
+        Log.error (fun k -> k "websocket: client's frames must be masked");
+        raise Close_connection
+      );
+
+      (* update state *)
+      r.remaining_bytes <- r.remaining_bytes - n;
+      r.num_read <- r.num_read + n;
+      if r.remaining_bytes = 0 then self.state <- Begin;
+      n
+    | Begin ->
+      read_frame_header self;
+      Log.debug (fun k ->
+          k "websocket: read frame of type=%s payload_len=%d key=%S"
+            (Frame_type.show self.header.ty)
+            self.header.payload_len
+            (Bytes.unsafe_to_string self.header.mask_key));
+
+      (match self.header.ty with
+      | 0 ->
+        (* continuation *)
+        if self.last_ty = 1 || self.last_ty = 2 then
+          self.state <-
+            Reading_frame
+              { remaining_bytes = self.header.payload_len; num_read = 0 }
+        else (
+          Log.error (fun k ->
+              k "continuation frame coming after frame of type %s"
+                (Frame_type.show self.last_ty));
+          raise Close_connection
+        );
+        read_rec self buf i len
+      | 1 ->
+        (* text *)
+        self.state <-
+          Reading_frame
+            { remaining_bytes = self.header.payload_len; num_read = 0 };
+        read_rec self buf i len
+      | 2 ->
+        (* binary *)
+        self.state <-
+          Reading_frame
+            { remaining_bytes = self.header.payload_len; num_read = 0 };
+        read_rec self buf i len
+      | 8 ->
+        (* close frame *)
+        self.state <- Close;
+        let body = read_body_to_string self in
+        if String.length body >= 2 then (
+          let errcode = Bytes.get_int16_be (Bytes.unsafe_of_string body) 0 in
+          Log.info (fun k ->
+              k "client send 'close' with errcode=%d, message=%S" errcode
+                (String.sub body 2 (String.length body - 2)))
+        );
+        0
+      | 9 ->
+        (* ping, reply *)
+        skip_body self;
+        Writer.send_pong self.writer;
+        read_rec self buf i len
+      | 10 ->
+        (* pong, just ignore *)
+        skip_body self;
+        read_rec self buf i len
+      | ty ->
+        Log.error (fun k -> k "unknown frame type: %xd" ty);
+        raise Close_connection)
+
+  let read self buf i len =
+    try read_rec self buf i len
+    with Close_connection ->
+      self.state <- Close;
+      0
+
+  let close self : unit =
+    if self.state != Close then (
+      Log.debug (fun k -> k "websocket: close connection from server side");
+      self.state <- Close
+    )
+end
+
+let upgrade ?(with_lock = With_lock.default_builder ()) ic oc : _ * _ =
+  let writer = Writer.create ~with_lock ~oc () in
+  let reader = Reader.create ~ic ~writer () in
+  let ws_ic : IO.Input.t =
+    object
+      inherit IO.Input.t_from_refill ~bytes:(Bytes.create 4_096) ()
+
+      method private refill (slice : IO.Slice.t) =
+        slice.off <- 0;
+        slice.len <- Reader.read reader slice.bytes 0 (Bytes.length slice.bytes)
+
+      method close () = Reader.close reader
+    end
+  in
+  let ws_oc : IO.Output.t =
+    object
+      method close () = Writer.close writer
+      method flush () = Writer.flush writer
+      method output bs i len = Writer.output writer bs i len
+      method output_char c = Writer.output_char writer c
+    end
+  in
+  ws_ic, ws_oc
+
+(** 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 with_lock : With_lock.builder
+  val handler : handler
+end) : Server.UPGRADE_HANDLER with type handshake_state = unit Request.t =
+struct
+  type handshake_state = unit Request.t
+
+  let name = "websocket"
+
+  open struct
+    exception Bad_req of string
+
+    let bad_req msg = raise (Bad_req msg)
+    let bad_reqf fmt = Printf.ksprintf bad_req fmt
+  end
+
+  let handshake_ (req : unit Request.t) =
+    (match Request.get_header req "sec-websocket-protocol" with
+    | None -> ()
+    | Some proto when not (X.accept_ws_protocol proto) ->
+      bad_reqf "handler rejected websocket protocol %S" proto
+    | Some _proto -> ());
+    let key =
+      match Request.get_header req "sec-websocket-key" with
+      | None -> bad_req "need sec-websocket-key"
+      | Some k -> k
+    in
+
+    (* TODO: "origin" header *)
+
+    (* produce the accept key *)
+    let accept =
+      (* yes, SHA1 is broken. It's also part of the spec for websockets. *)
+      Utils_.sha_1 (key ^ "258EAFA5-E914-47DA-95CA-C5AB0DC85B11")
+      |> Utils_.B64.encode ~url:false
+    in
+
+    let headers = [ "sec-websocket-accept", accept ] in
+    Log.debug (fun k ->
+        k "websocket: upgrade successful, accept key is %S" accept);
+    headers, req
+
+  let handshake _addr req : _ result =
+    try Ok (handshake_ req) with Bad_req s -> Error s
+
+  let handle_connection req ic oc =
+    let with_lock = X.with_lock () in
+    let ws_ic, ws_oc = upgrade ~with_lock ic oc in
+    try X.handler req ws_ic ws_oc
+    with Close_connection ->
+      Log.debug (fun k -> k "websocket: requested to close the connection");
+      ()
+end
+
+let add_route_handler ?accept ?(accept_ws_protocol = fun _ -> true) ?middlewares
+    ?(with_lock = With_lock.default_builder) (server : Server.t) route
+    (f : handler) : unit =
+  let module M = Make_upgrade_handler (struct
+    let handler = f
+    let with_lock = with_lock
+    let accept_ws_protocol = accept_ws_protocol
+  end) in
+  let up : Server.upgrade_handler = (module M) in
+  Server.add_upgrade_handler ?accept ?middlewares server route up
+
+module Private_ = struct
+  let apply_masking = Reader.apply_masking
+end

src/ws/tiny_httpd_ws.mli

@@ -0,0 +1,66 @@
+(** Websockets for Tiny_httpd.
+
+    This sub-library ([tiny_httpd.ws]) exports a small implementation for a
+    websocket server. It has no additional dependencies. *)
+
+(** Synchronization primitive used to allow both the reader to reply to "ping",
+    and the handler to send messages, without stepping on each other's toes.
+
+    @since NEXT_RELEASE *)
+module With_lock : sig
+  type t = { with_lock: 'a. (unit -> 'a) -> 'a }
+  (** A primitive to run the callback in a critical section where others cannot
+      run at the same time.
+
+      The default is a mutex, but that works poorly with thread pools so it's
+      possible to use a semaphore or a cooperative mutex instead. *)
+
+  type builder = unit -> t
+
+  val default_builder : builder
+  (** Lock using [Mutex]. *)
+end
+
+type handler = unit Request.t -> IO.Input.t -> IO.Output.t -> unit
+(** Websocket handler *)
+
+val upgrade :
+  ?with_lock:With_lock.t ->
+  IO.Input.t ->
+  IO.Output.t ->
+  IO.Input.t * IO.Output.t
+(** Upgrade a byte stream to the websocket framing protocol.
+    @param with_lock
+      if provided, use this to prevent reader and writer to compete on sending
+      frames. since NEXT_RELEASE. *)
+
+exception Close_connection
+(** 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) ->
+  ?accept_ws_protocol:(string -> bool) ->
+  ?middlewares:Server.Head_middleware.t list ->
+  ?with_lock:With_lock.builder ->
+  Server.t ->
+  (Server.upgrade_handler, Server.upgrade_handler) Route.t ->
+  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 with_lock
+      if provided, use this to synchronize writes between the frame reader
+      (replies "pong" to "ping") and the handler emitting writes. since
+      NEXT_RELEASE. *)
+
+(**/**)
+
+module Private_ : sig
+  val apply_masking :
+    mask_key:bytes -> mask_offset:int -> bytes -> int -> int -> unit
+end
+
+(**/**)

src/ws/tiny_httpd_ws_stubs.c

@@ -0,0 +1,22 @@
+
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+CAMLprim value tiny_httpd_ws_apply_masking(value _mask_key, value _mask_offset, value _buf,
+                                           value _offset, value _len) {
+  CAMLparam5(_mask_key, _mask_offset, _buf, _offset, _len);
+
+  char const *mask_key = String_val(_mask_key);
+  unsigned char *buf = Bytes_val(_buf);
+  intnat mask_offset = Int_val(_mask_offset);
+  intnat offset = Int_val(_offset);
+  intnat len = Int_val(_len);
+
+  for (intnat i = 0; i < len; ++i) {
+    unsigned char c = buf[offset + i];
+    unsigned char c_m = mask_key[(i + mask_offset) & 0x3];
+    buf[offset + i] = (unsigned char)(c ^ c_m);
+  }
+  CAMLreturn(Val_unit);
+}

src/ws/utils_.ml

@@ -0,0 +1,198 @@
+(* To keep the library lightweight, we vendor base64 and sha1
+   from Daniel Bünzli's excellent libraries. Both of these functions
+   are used only for the websocket handshake, on tiny data
+   (one header's worth).
+
+   vendored from https://github.com/dbuenzli/uuidm
+   and https://github.com/dbuenzli/webs . *)
+
+module B64 = struct
+  let alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+
+  let alpha_url =
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"
+
+  let encode ~url s =
+    let rec loop alpha len e ei s i =
+      if i >= len then
+        Bytes.unsafe_to_string e
+      else (
+        let i0 = i and i1 = i + 1 and i2 = i + 2 in
+        let b0 = Char.code s.[i0] in
+        let b1 =
+          if i1 >= len then
+            0
+          else
+            Char.code s.[i1]
+        in
+        let b2 =
+          if i2 >= len then
+            0
+          else
+            Char.code s.[i2]
+        in
+        let u = (b0 lsl 16) lor (b1 lsl 8) lor b2 in
+        let c0 = alpha.[u lsr 18] in
+        let c1 = alpha.[(u lsr 12) land 63] in
+        let c2 =
+          if i1 >= len then
+            '='
+          else
+            alpha.[(u lsr 6) land 63]
+        in
+        let c3 =
+          if i2 >= len then
+            '='
+          else
+            alpha.[u land 63]
+        in
+        Bytes.set e ei c0;
+        Bytes.set e (ei + 1) c1;
+        Bytes.set e (ei + 2) c2;
+        Bytes.set e (ei + 3) c3;
+        loop alpha len e (ei + 4) s (i2 + 1)
+      )
+    in
+    match String.length s with
+    | 0 -> ""
+    | len ->
+      let alpha =
+        if url then
+          alpha_url
+        else
+          alpha
+      in
+      loop alpha len (Bytes.create ((len + 2) / 3 * 4)) 0 s 0
+end
+
+let sha_1 s =
+  (* Based on pseudo-code of RFC 3174. Slow and ugly but does the job. *)
+  let sha_1_pad s =
+    let len = String.length s in
+    let blen = 8 * len in
+    let rem = len mod 64 in
+    let mlen =
+      if rem > 55 then
+        len + 128 - rem
+      else
+        len + 64 - rem
+    in
+    let m = Bytes.create mlen in
+    Bytes.blit_string s 0 m 0 len;
+    Bytes.fill m len (mlen - len) '\x00';
+    Bytes.set m len '\x80';
+    if Sys.word_size > 32 then (
+      Bytes.set m (mlen - 8) (Char.unsafe_chr ((blen lsr 56) land 0xFF));
+      Bytes.set m (mlen - 7) (Char.unsafe_chr ((blen lsr 48) land 0xFF));
+      Bytes.set m (mlen - 6) (Char.unsafe_chr ((blen lsr 40) land 0xFF));
+      Bytes.set m (mlen - 5) (Char.unsafe_chr ((blen lsr 32) land 0xFF))
+    );
+    Bytes.set m (mlen - 4) (Char.unsafe_chr ((blen lsr 24) land 0xFF));
+    Bytes.set m (mlen - 3) (Char.unsafe_chr ((blen lsr 16) land 0xFF));
+    Bytes.set m (mlen - 2) (Char.unsafe_chr ((blen lsr 8) land 0xFF));
+    Bytes.set m (mlen - 1) (Char.unsafe_chr (blen land 0xFF));
+    m
+  in
+  (* Operations on int32 *)
+  let ( &&& ) = ( land ) in
+  let ( lor ) = Int32.logor in
+  let ( lxor ) = Int32.logxor in
+  let ( land ) = Int32.logand in
+  let ( ++ ) = Int32.add in
+  let lnot = Int32.lognot in
+  let sr = Int32.shift_right in
+  let sl = Int32.shift_left in
+  let cls n x = sl x n lor Int32.shift_right_logical x (32 - n) in
+  (* Start *)
+  let m = sha_1_pad s in
+  let w = Array.make 16 0l in
+  let h0 = ref 0x67452301l in
+  let h1 = ref 0xEFCDAB89l in
+  let h2 = ref 0x98BADCFEl in
+  let h3 = ref 0x10325476l in
+  let h4 = ref 0xC3D2E1F0l in
+  let a = ref 0l in
+  let b = ref 0l in
+  let c = ref 0l in
+  let d = ref 0l in
+  let e = ref 0l in
+  for i = 0 to (Bytes.length m / 64) - 1 do
+    (* For each block *)
+    (* Fill w *)
+    let base = i * 64 in
+    for j = 0 to 15 do
+      let k = base + (j * 4) in
+      w.(j) <-
+        sl (Int32.of_int (Char.code @@ Bytes.get m k)) 24
+        lor sl (Int32.of_int (Char.code @@ Bytes.get m (k + 1))) 16
+        lor sl (Int32.of_int (Char.code @@ Bytes.get m (k + 2))) 8
+        lor Int32.of_int (Char.code @@ Bytes.get m (k + 3))
+    done;
+    (* Loop *)
+    a := !h0;
+    b := !h1;
+    c := !h2;
+    d := !h3;
+    e := !h4;
+    for t = 0 to 79 do
+      let f, k =
+        if t <= 19 then
+          !b land !c lor (lnot !b land !d), 0x5A827999l
+        else if t <= 39 then
+          !b lxor !c lxor !d, 0x6ED9EBA1l
+        else if t <= 59 then
+          !b land !c lor (!b land !d) lor (!c land !d), 0x8F1BBCDCl
+        else
+          !b lxor !c lxor !d, 0xCA62C1D6l
+      in
+      let s = t &&& 0xF in
+      if t >= 16 then
+        w.(s) <-
+          cls 1
+            (w.(s + 13 &&& 0xF)
+            lxor w.(s + 8 &&& 0xF)
+            lxor w.(s + 2 &&& 0xF)
+            lxor w.(s));
+      let temp = cls 5 !a ++ f ++ !e ++ w.(s) ++ k in
+      e := !d;
+      d := !c;
+      c := cls 30 !b;
+      b := !a;
+      a := temp
+    done;
+    (* Update *)
+    h0 := !h0 ++ !a;
+    h1 := !h1 ++ !b;
+    h2 := !h2 ++ !c;
+    h3 := !h3 ++ !d;
+    h4 := !h4 ++ !e
+  done;
+  let h = Bytes.create 20 in
+  let i2s h k i =
+    Bytes.set h k (Char.unsafe_chr (Int32.to_int (sr i 24) &&& 0xFF));
+    Bytes.set h (k + 1) (Char.unsafe_chr (Int32.to_int (sr i 16) &&& 0xFF));
+    Bytes.set h (k + 2) (Char.unsafe_chr (Int32.to_int (sr i 8) &&& 0xFF));
+    Bytes.set h (k + 3) (Char.unsafe_chr (Int32.to_int i &&& 0xFF))
+  in
+  i2s h 0 !h0;
+  i2s h 4 !h1;
+  i2s h 8 !h2;
+  i2s h 12 !h3;
+  i2s h 16 !h4;
+  Bytes.unsafe_to_string h
+
+(*---------------------------------------------------------------------------
+   Copyright (c) 2008 The uuidm programmers
+
+   Permission to use, copy, modify, and/or distribute this software for any
+   purpose with or without fee is hereby granted, provided that the above
+   copyright notice and this permission notice appear in all copies.
+
+   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+   WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+   MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+   ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+   WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+   ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+   OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+  ---------------------------------------------------------------------------*)

tests/dl-out.expect

@@ -1,5 +1,5 @@
 serve directory . on http://127.0.0.1:8088
-        0         0  52428800 data21
-        0         0  52428800 data22
-        0         0  52428800 data23
-        0         0 157286400 total
+ 52428800 data21
+ 52428800 data22
+ 52428800 data23
+157286400 total

tests/download_chunked.sh

@@ -20,4 +20,4 @@ curl -N "http://localhost:${PORT}/foo_50" -o data23 \
   -H 'Accept-encoding: chunked' --max-time 10
 
 kill $PID
-wc data21 data22 data23
+wc -m data21 data22 data23

tests/echo1.expect

@@ -2,8 +2,8 @@ listening on http://127.0.0.1:8085
 echo:
 {meth=GET; host=localhost:8085;
  headers=[user-agent: test
-          accept: */*
-          host: localhost:8085];
+          Accept: */*
+          Host: localhost:8085];
  path="/echo/?a=b&c=d"; body=""; path_components=["echo"];
  query=["c","d";"a","b"]}
 (query: "c" = "d";"a" = "b")
@@ -50,6 +50,7 @@ test_out.txt
 </html>
 hello
 world
+ykjNycnnKs8vyknhAgAAAP//
 
 <html>
 <head>

tests/echo1.sh

@@ -14,6 +14,12 @@ curl -N "http://localhost:${PORT}/vfs/" --max-time 5
 sleep 0.1
 curl -N "http://localhost:${PORT}/vfs/a.txt" --max-time 5
 
+sleep 0.1
+# NOTE: the sed is there because of a timing/deflate non determinism. Both strings
+# decompress to the same "hello\nworld\n" but which one is picked depends on
+# the machine/library/… ?? but both are valid.
+curl -N "http://localhost:${PORT}/vfs/a.txt" -H 'accept-encoding: deflate' --max-time 5 | base64 | sed 's+ykjNycnnKs8vyknhAgAAAP//AwA=+ykjNycnnKs8vyknhAgAAAP//+'
+
 sleep 0.1
 curl -N "http://localhost:${PORT}/vfs/sub/yolo.html" --max-time 5
 

tests/multipart_form/dune

@@ -0,0 +1,3 @@
+(tests
+ (names t_chunk t_parse t_content_type t_content_disposition)
+ (libraries tiny_httpd tiny_httpd.multipart-form-data))

tests/multipart_form/t_chunk.expected

@@ -0,0 +1,25 @@
+T1
+chunk "hello"
+delim
+chunk "\n  world\n    what is the meaning of"
+delim
+chunk "this??"
+delim
+chunk "ok ok ok"
+delim
+T2
+delim
+delim
+chunk "ah bon"
+delim
+chunk "aight"
+delim
+delim
+T3
+delim
+chunk "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+delim
+delim
+chunk "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
+delim
+chunk "cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc"

tests/multipart_form/t_chunk.ml

@@ -0,0 +1,53 @@
+module MFD = Tiny_httpd_multipart_form_data
+
+let spf = Printf.sprintf
+let pf = Printf.printf
+
+let read_stream (st : MFD.st) : _ list =
+  let l = ref [] in
+  let buf = Bytes.create 12 in
+  let buffer = Buffer.create 32 in
+  let rec loop () =
+    match MFD.Private_.read_chunk_ st buf 0 (Bytes.length buf) with
+    | Delim ->
+      if Buffer.length buffer > 0 then l := `Str (Buffer.contents buffer) :: !l;
+      Buffer.clear buffer;
+      l := `Delim :: !l;
+      loop ()
+    | Read n ->
+      Buffer.add_subbytes buffer buf 0 n;
+      loop ()
+    | Eof ->
+      if Buffer.length buffer > 0 then l := `Str (Buffer.contents buffer) :: !l;
+      List.rev !l
+  in
+  loop ()
+
+let test input_str =
+  let st =
+    MFD.create ~buf_size:16 ~boundary:"YOLO" (Iostream.In.of_string input_str)
+  in
+  let chunks = read_stream st in
+  List.iter
+    (function
+      | `Delim -> pf "delim\n"
+      | `Str s -> pf "chunk %S\n" s)
+    chunks;
+  ()
+
+let () =
+  pf "T1\n";
+  test
+    "hello--YOLO\n\
+    \  world\n\
+    \    what is the meaning of\r\n\
+     --YOLOthis??\r\n\
+     --YOLOok ok ok\r\n\
+     --YOLO";
+  pf "T2\n";
+  test "--YOLO\r\n--YOLOah bon\r\n--YOLOaight\r\n--YOLO\r\n--YOLO";
+  pf "T3\n";
+  test
+    (spf "--YOLO%s\r\n--YOLO\r\n--YOLO%s\r\n--YOLO%s" (String.make 400 'a')
+       (String.make 512 'b') (String.make 400 'c'));
+  ()

tests/multipart_form/t_content_disposition.expected

@@ -0,0 +1,3 @@
+h: ["content-foobar": "yolo";"other": "whatev"], no content disp
+h ["content-disposition": "form-data; name=helloworld; junk";"other": "whatev"]: got {kind="form-data"; name="helloworld"; filename=None}, expected {kind="form-data"; name="helloworld"; filename=None}, same=true
+h ["content-disposition": "form-data; lol=mdr; filename=\"some quoted stuff\""]: got {kind="form-data"; name=None; filename="some quoted stuff"}, expected {kind="form-data"; name=None; filename="some quoted stuff"}, same=true

tests/multipart_form/t_content_disposition.ml

@@ -0,0 +1,39 @@
+module MFD = Tiny_httpd_multipart_form_data
+
+let pf = Printf.printf
+let spf = Printf.sprintf
+
+let pp_headers hs =
+  spf "[%s]" (String.concat ";" @@ List.map (fun (k, v) -> spf "%S: %S" k v) hs)
+
+let test_headers h (exp : _ option) =
+  match MFD.Content_disposition.parse h, exp with
+  | Some c1, Some c2 ->
+    pf "h %s: got %s, expected %s, same=%b\n" (pp_headers h)
+      (MFD.Content_disposition.to_string c1)
+      (MFD.Content_disposition.to_string c2)
+      (c1 = c2)
+  | Some c1, None ->
+    pf "h: %s, unexpected content disp %s\n" (pp_headers h)
+      (MFD.Content_disposition.to_string c1)
+  | None, Some c2 ->
+    pf "h: %s, expected content disp %s\n" (pp_headers h)
+      (MFD.Content_disposition.to_string c2)
+  | None, None -> pf "h: %s, no content disp\n" (pp_headers h)
+
+let () =
+  test_headers [ "content-foobar", "yolo"; "other", "whatev" ] None;
+  test_headers
+    [
+      "content-disposition", "form-data; name=helloworld; junk";
+      "other", "whatev";
+    ]
+    (Some { kind = "form-data"; name = Some "helloworld"; filename = None });
+  test_headers
+    [
+      ( "content-disposition",
+        "form-data; lol=mdr; filename=\"some quoted stuff\"" );
+    ]
+    (Some
+       { kind = "form-data"; name = None; filename = Some "some quoted stuff" });
+  ()

tests/multipart_form/t_content_type.expected

@@ -0,0 +1,3 @@
+h: ["content-type": "yolo";"other": "whatev"], no content type
+h ["content-type": "multipart/form-data; boundary=helloworld; junk";"other": "whatev"]: got "helloworld", expected "helloworld", same=true
+h ["content-type": "multipart/form-data; lol=mdr;  boundary=\"some quoted boundary\""]: got "some quoted boundary", expected "some quoted boundary", same=true

tests/multipart_form/t_content_type.ml

@@ -0,0 +1,32 @@
+module MFD = Tiny_httpd_multipart_form_data
+
+let pf = Printf.printf
+let spf = Printf.sprintf
+
+let pp_headers hs =
+  spf "[%s]" (String.concat ";" @@ List.map (fun (k, v) -> spf "%S: %S" k v) hs)
+
+let test_headers h (exp : string option) =
+  match MFD.parse_content_type h, exp with
+  | Some (`boundary c1), Some c2 ->
+    pf "h %s: got %S, expected %S, same=%b\n" (pp_headers h) c1 c2 (c1 = c2)
+  | Some (`boundary c1), None ->
+    pf "h: %s, unexpected content type %S\n" (pp_headers h) c1
+  | None, Some c2 -> pf "h: %s, expected content type %S\n" (pp_headers h) c2
+  | None, None -> pf "h: %s, no content type\n" (pp_headers h)
+
+let () =
+  test_headers [ "content-type", "yolo"; "other", "whatev" ] None;
+  test_headers
+    [
+      "content-type", "multipart/form-data; boundary=helloworld; junk";
+      "other", "whatev";
+    ]
+    (Some "helloworld");
+  test_headers
+    [
+      ( "content-type",
+        "multipart/form-data; lol=mdr;  boundary=\"some quoted boundary\"" );
+    ]
+    (Some "some quoted boundary");
+  ()