From 3e7c73093e6057b26efd7035308ea299856b2410 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 1 May 2025 15:37:09 -0400 Subject: [PATCH 01/18] feat: `tiny_httpd_eio` library provides a tiny_httpd server that relies on Eio for non-blocking sockets and for concurrency using eio fibers. --- dune-project | 9 ++ src/eio/dune | 8 ++ src/eio/tiny_httpd_eio.ml | 207 +++++++++++++++++++++++++++++++++++++ src/eio/tiny_httpd_eio.mli | 31 ++++++ tiny_httpd_eio.opam | 31 ++++++ 5 files changed, 286 insertions(+) create mode 100644 src/eio/dune create mode 100644 src/eio/tiny_httpd_eio.ml create mode 100644 src/eio/tiny_httpd_eio.mli create mode 100644 tiny_httpd_eio.opam diff --git a/dune-project b/dune-project index 7ff0c109..7c4a4a12 100644 --- a/dune-project +++ b/dune-project @@ -39,3 +39,12 @@ (iostream-camlzip (>= 0.2.1)) (logs :with-test) (odoc :with-doc))) + +(package + (name tiny_httpd_eio) + (synopsis "Use eio for tiny_httpd") + (depends + (tiny_httpd (= :version)) + eio + (logs :with-test) + (odoc :with-doc))) diff --git a/src/eio/dune b/src/eio/dune new file mode 100644 index 00000000..37431aba --- /dev/null +++ b/src/eio/dune @@ -0,0 +1,8 @@ + +(library + (name tiny_httpd_eio) + (public_name tiny_httpd_eio) + (synopsis "An EIO-based backend for Tiny_httpd") + (flags :standard -safe-string -warn-error -a+8) + (libraries tiny_httpd eio eio.unix)) + diff --git a/src/eio/tiny_httpd_eio.ml b/src/eio/tiny_httpd_eio.ml new file mode 100644 index 00000000..e58d1b6b --- /dev/null +++ b/src/eio/tiny_httpd_eio.ml @@ -0,0 +1,207 @@ +module IO = Tiny_httpd.IO +module H = Tiny_httpd.Server +module Pool = Tiny_httpd.Pool +module Slice = IO.Slice +module Log = Tiny_httpd.Log + +let ( let@ ) = ( @@ ) + +type 'a with_args = + ?addr:string -> + ?port:int -> + ?unix_sock:string -> + ?max_connections:int -> + ?max_buf_pool_size:int -> + stdenv:Eio_unix.Stdenv.base -> + sw:Eio.Switch.t -> + 'a + +let get_max_connection_ ?(max_connections = 64) () : int = + let max_connections = max 4 max_connections in + max_connections + +let buf_size = 16 * 1024 + +let eio_ipaddr_to_unix (a : _ Eio.Net.Ipaddr.t) : Unix.inet_addr = + (* TODO: for ipv4 we really could do it faster via sprintf 🙄 *) + Unix.inet_addr_of_string (Format.asprintf "%a" Eio.Net.Ipaddr.pp a) + +let eio_sock_addr_to_unix (a : Eio.Net.Sockaddr.stream) : Unix.sockaddr = + match a with + | `Tcp (h, p) -> Unix.ADDR_INET (eio_ipaddr_to_unix h, p) + | `Unix s -> Unix.ADDR_UNIX s + +let ic_of_flow ~buf_pool:ic_pool (flow : _ Eio.Net.stream_socket) : IO.Input.t = + let cstruct = Pool.Raw.acquire ic_pool in + + object + inherit Iostream.In_buf.t_from_refill () + + method private refill (sl : Slice.t) = + assert (sl.len = 0); + let cap = min (Bytes.length sl.bytes) (Cstruct.length cstruct) in + + match Eio.Flow.single_read flow (Cstruct.sub cstruct 0 cap) with + | exception End_of_file -> + Log.debug (fun k -> k "read: eof"); + () + | n -> + Log.debug (fun k -> k "read %d bytes..." n); + Cstruct.blit_to_bytes cstruct 0 sl.bytes 0 n; + sl.off <- 0; + sl.len <- n + + method close () = + Pool.Raw.release ic_pool cstruct; + Eio.Flow.shutdown flow `Receive + end + +let oc_of_flow ~buf_pool:oc_pool (flow : _ Eio.Net.stream_socket) : IO.Output.t + = + (* write buffer *) + let wbuf : Cstruct.t = Pool.Raw.acquire oc_pool in + let offset = ref 0 in + + object (self) + method flush () : unit = + if !offset > 0 then ( + Eio.Flow.write flow [ Cstruct.sub wbuf 0 !offset ]; + offset := 0 + ) + + method output buf i len = + let i = ref i in + let len = ref len in + + while !len > 0 do + let available = Cstruct.length wbuf - !offset in + let n = min !len available in + Cstruct.blit_from_bytes buf !i wbuf !offset n; + offset := !offset + n; + i := !i + n; + len := !len - n; + + if !offset = Cstruct.length wbuf then self#flush () + done + + method output_char c = + if !offset = Cstruct.length wbuf then self#flush (); + Cstruct.set_char wbuf !offset c; + incr offset; + if !offset = Cstruct.length wbuf then self#flush () + + method close () = + Pool.Raw.release oc_pool wbuf; + Eio.Flow.shutdown flow `Send + end + +let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size + ~(stdenv : Eio_unix.Stdenv.base) ~(sw : Eio.Switch.t) () : + (module H.IO_BACKEND) = + let addr, port, (sockaddr : Eio.Net.Sockaddr.stream) = + match addr, port, unix_sock with + | _, _, Some s -> Printf.sprintf "unix:%s" s, 0, `Unix s + | addr, port, None -> + let addr = Option.value ~default:"127.0.0.1" addr in + let sockaddr, port = + match Eio.Net.getaddrinfo stdenv#net addr, port with + | `Tcp (h, _) :: _, None -> + let p = 8080 in + `Tcp (h, p), p + | `Tcp (h, _) :: _, Some p -> `Tcp (h, p), p + | _ -> + failwith @@ Printf.sprintf "Could not parse TCP address from %S" addr + in + addr, port, sockaddr + in + + let module M = struct + let init_addr () = addr + let init_port () = port + let get_time_s () = Unix.gettimeofday () + let max_connections = get_max_connection_ ?max_connections () + + let pool_size = + match max_buf_pool_size with + | Some n -> n + | None -> min 4096 (max_connections * 2) + + let cstruct_pool = + Pool.create ~max_size:max_connections + ~mk_item:(fun () -> Cstruct.create buf_size) + () + + let tcp_server () : IO.TCP_server.builder = + { + IO.TCP_server.serve = + (fun ~after_init ~handle () : unit -> + let running = Atomic.make true in + let active_conns = Atomic.make 0 in + + Eio.Switch.on_release sw (fun () -> Atomic.set running false); + let net = Eio.Stdenv.net stdenv in + + (* main server socket *) + let sock = + let backlog = max_connections in + Eio.Net.listen ~reuse_addr:true ~reuse_port:true ~backlog ~sw net + sockaddr + in + + let tcp_server : IO.TCP_server.t = + { + running = (fun () -> Atomic.get running); + stop = + (fun () -> + Atomic.set running false; + Eio.Switch.fail sw Exit); + endpoint = + (fun () -> + (* TODO: find the real port *) + addr, port); + active_connections = (fun () -> Atomic.get active_conns); + } + in + + after_init tcp_server; + + while Atomic.get running do + Eio.Net.accept_fork ~sw + ~on_error:(fun exn -> + Log.error (fun k -> + k "error in client handler: %s" (Printexc.to_string exn))) + sock + (fun flow client_addr -> + Atomic.incr active_conns; + let@ () = + Fun.protect ~finally:(fun () -> + Log.debug (fun k -> + k "Tiny_httpd_eio: client handler returned"); + Atomic.decr active_conns) + in + let ic = ic_of_flow ~buf_pool:cstruct_pool flow in + let oc = oc_of_flow ~buf_pool:cstruct_pool flow in + + Log.debug (fun k -> + k "handling client on %a…" Eio.Net.Sockaddr.pp client_addr); + let client_addr_unix = eio_sock_addr_to_unix client_addr in + try handle.handle ~client_addr:client_addr_unix ic oc + with exn -> + let bt = Printexc.get_raw_backtrace () in + Log.error (fun k -> + k "Client handler for %a failed with %s\n%s" + Eio.Net.Sockaddr.pp client_addr + (Printexc.to_string exn) + (Printexc.raw_backtrace_to_string bt))) + done); + } + end in + (module M) + +let create ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size ~stdenv + ~sw ?buf_size ?middlewares () : H.t = + let backend = + io_backend ?addr ?port ?unix_sock ?max_buf_pool_size ?max_connections + ~stdenv ~sw () + in + H.create_from ?buf_size ?middlewares ~backend () diff --git a/src/eio/tiny_httpd_eio.mli b/src/eio/tiny_httpd_eio.mli new file mode 100644 index 00000000..3183ef49 --- /dev/null +++ b/src/eio/tiny_httpd_eio.mli @@ -0,0 +1,31 @@ +(** Tiny httpd EIO backend. + + This replaces the threads + Unix blocking syscalls of {!Tiny_httpd_server} + with an Eio-based cooperative system. + + {b NOTE}: this is very experimental and will absolutely change over time, + especially since Eio itself is also subject to change. + @since NEXT_RELEASE *) + +(* TODO: pass in a switch *) + +type 'a with_args = + ?addr:string -> + ?port:int -> + ?unix_sock:string -> + ?max_connections:int -> + ?max_buf_pool_size:int -> + stdenv:Eio_unix.Stdenv.base -> + sw:Eio.Switch.t -> + 'a + +val io_backend : (unit -> (module Tiny_httpd.Server.IO_BACKEND)) with_args +(** Create a server *) + +val create : + (?buf_size:int -> + ?middlewares:([ `Encoding | `Stage of int ] * Tiny_httpd.Middleware.t) list -> + unit -> + Tiny_httpd.Server.t) + with_args +(** Create a server *) diff --git a/tiny_httpd_eio.opam b/tiny_httpd_eio.opam new file mode 100644 index 00000000..cdc15a35 --- /dev/null +++ b/tiny_httpd_eio.opam @@ -0,0 +1,31 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "0.19" +synopsis: "Use eio for tiny_httpd" +maintainer: ["c-cube"] +authors: ["c-cube"] +license: "MIT" +homepage: "https://github.com/c-cube/tiny_httpd/" +bug-reports: "https://github.com/c-cube/tiny_httpd/issues" +depends: [ + "dune" {>= "3.2"} + "tiny_httpd" {= version} + "eio" + "logs" {with-test} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/c-cube/tiny_httpd.git" From 0e35e38c092279375827ddaad3303b955d874d15 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 1 May 2025 15:43:05 -0400 Subject: [PATCH 02/18] example with eio --- echo_eio.sh | 2 + examples/dune | 25 ++- examples/echo_eio.ml | 412 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 438 insertions(+), 1 deletion(-) create mode 100755 echo_eio.sh create mode 100644 examples/echo_eio.ml diff --git a/echo_eio.sh b/echo_eio.sh new file mode 100755 index 00000000..5621bddc --- /dev/null +++ b/echo_eio.sh @@ -0,0 +1,2 @@ +#!/bin/sh +exec dune exec --display=quiet --profile=release "examples/echo_eio.exe" -- $@ diff --git a/examples/dune b/examples/dune index de7ccfc4..78350f9a 100644 --- a/examples/dune +++ b/examples/dune @@ -11,10 +11,27 @@ (executable (name echo) (flags :standard -warn-error -a+8) - (modules echo vfs) + (modules echo) (libraries tiny_httpd logs + echo_vfs + tiny_httpd_camlzip + tiny_httpd.multipart-form-data)) + +(executable + (name echo_eio) + (flags :standard -warn-error -a+8) + (modules echo_eio) + (libraries + tiny_httpd + tiny_httpd_eio + eio + eio_main + logs + echo_vfs + trace.core + trace-tef tiny_httpd_camlzip tiny_httpd.multipart-form-data)) @@ -55,6 +72,12 @@ ; produce an embedded FS +(library + (name echo_vfs) + (modules vfs) + (wrapped false) + (libraries tiny_httpd)) + (rule (targets vfs.ml) (deps diff --git a/examples/echo_eio.ml b/examples/echo_eio.ml new file mode 100644 index 00000000..5905fe57 --- /dev/null +++ b/examples/echo_eio.ml @@ -0,0 +1,412 @@ +open Tiny_httpd_core +module Trace = Trace_core +module Log = Tiny_httpd.Log +module MFD = Tiny_httpd_multipart_form_data + +let ( let@ ) = ( @@ ) +let now_ = Unix.gettimeofday + +let alice_text = + "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of \ + sitting by her sister on the bank, and of having nothing to do: once or \ + twice she had peeped into the book her sister was reading, but it had no \ + pictures or conversations in it, thought \ + Alice So she was considering in her \ + own mind (as well as she could, for the hot day made her feel very sleepy \ + and stupid), whether the pleasure of making a daisy-chain would be worth \ + the trouble of getting up and picking the daisies, when suddenly a White \ + Rabbit with pink eyes ran close by her. There was nothing so very \ + remarkable in that; nor did Alice think it so very much out of the way to \ + hear the Rabbit say to itself, (when \ + she thought it over afterwards, it occurred to her that she ought to have \ + wondered at this, but at the time it all seemed quite natural); but when \ + the Rabbit actually took a watch out of its waistcoat-pocket, and looked at \ + it, and then hurried on, Alice started to her feet, for it flashed across \ + her mind that she had never before seen a rabbit with either a \ + waistcoat-pocket, or a watch to take out of it, and burning with curiosity, \ + she ran across the field after it, and fortunately was just in time to see \ + it pop down a large rabbit-hole under the hedge. In another moment down \ + went Alice after it, never once considering how in the world she was to get \ + out again. The rabbit-hole went straight on like a tunnel for some way, and \ + then dipped suddenly down, so suddenly that Alice had not a moment to think \ + about stopping herself before she found herself falling down a very deep \ + well. Either the well was very deep, or she fell very slowly, for she had \ + plenty of time as she went down to look about her and to wonder what was \ + going to happen next. First, she tried to look down and make out what she \ + was coming to, but it was too dark to see anything; then she looked at the \ + sides of the well, and noticed that they were filled with cupboards......" + +(* util: a little middleware collecting statistics *) +let middleware_stat () : Server.Middleware.t * (unit -> string) = + let n_req = ref 0 in + let total_time_ = ref 0. in + let parse_time_ = ref 0. in + let build_time_ = ref 0. in + let write_time_ = ref 0. in + + let m h req ~resp = + incr n_req; + let t1 = Request.start_time req in + let t2 = now_ () in + h req ~resp:(fun response -> + let t3 = now_ () in + resp response; + let t4 = now_ () in + total_time_ := !total_time_ +. (t4 -. t1); + parse_time_ := !parse_time_ +. (t2 -. t1); + build_time_ := !build_time_ +. (t3 -. t2); + write_time_ := !write_time_ +. (t4 -. t3)) + and get_stat () = + Printf.sprintf + "%d requests (average response time: %.3fms = %.3fms + %.3fms + %.3fms)" + !n_req + (!total_time_ /. float !n_req *. 1e3) + (!parse_time_ /. float !n_req *. 1e3) + (!build_time_ /. float !n_req *. 1e3) + (!write_time_ /. float !n_req *. 1e3) + in + m, get_stat + +let middleware_trace : Server.Middleware.t = + fun (h : Server.Middleware.handler) req ~resp -> + let _sp = + Trace.enter_manual_toplevel_span ~__FILE__ ~__LINE__ "http.handle" + in + let new_resp (r : Response.t) = + Trace.add_data_to_manual_span _sp [ "http.code", `Int r.code ]; + Trace.exit_manual_span _sp; + resp r + in + h req ~resp:new_resp + +(* ugly AF *) +let base64 x = + let ic, oc = Unix.open_process "base64" in + output_string oc x; + flush oc; + close_out oc; + let r = input_line ic in + ignore (Unix.close_process (ic, oc)); + r + +let setup_logging () = + Logs.set_reporter @@ Logs.format_reporter (); + Logs.set_level ~all:true (Some Logs.Debug) + +let setup_upload server : unit = + Server.add_route_handler_stream ~meth:`POST server + Route.(exact "upload" @/ return) + (fun req -> + let (`boundary boundary) = + match MFD.parse_content_type req.headers with + | Some b -> b + | None -> Response.fail_raise ~code:400 "no boundary found" + in + + let st = MFD.create ~boundary req.body in + let tbl = Hashtbl.create 16 in + let cur = ref "" in + let cur_kind = ref "" in + let buf = Buffer.create 16 in + let rec loop () = + match MFD.next st with + | End_of_input -> + if !cur <> "" then + Hashtbl.add tbl !cur (!cur_kind, Buffer.contents buf) + | Part headers -> + if !cur <> "" then + Hashtbl.add tbl !cur (!cur_kind, Buffer.contents buf); + (match MFD.Content_disposition.parse headers with + | Some { kind; name = Some name; filename = _ } -> + cur := name; + cur_kind := kind; + Buffer.clear buf; + loop () + | _ -> Response.fail_raise ~code:400 "content disposition missing") + | Read sl -> + Buffer.add_subbytes buf sl.bytes sl.off sl.len; + loop () + in + loop (); + + let open Tiny_httpd_html in + let data = + Hashtbl.fold + (fun name (kind, data) acc -> + Printf.sprintf "%S (kind: %S): %S" name kind data :: acc) + tbl [] + in + let html = + body [] + [ + pre [] + [ txt (Printf.sprintf "{\n%s\n}" @@ String.concat "\n" data) ]; + ] + in + Response.make_string ~code:201 @@ Ok (to_string_top html)) + +let () = + let@ () = Trace_tef.with_setup () in + let port_ = ref 8080 in + let max_conns = ref 16_000 in + let pool_buf_size = ref None in + let buf_size = ref 4096 in + let unix_sock = ref "" in + let addr = ref "127.0.0.1" in + Arg.parse + (Arg.align + [ + "--port", Arg.Set_int port_, " set port"; + "-p", Arg.Set_int port_, " set port"; + "--unix", Arg.Set_string unix_sock, " set unix socket"; + "--debug", Arg.Unit setup_logging, " enable debug"; + ( "--max-buf-pool-size", + Arg.Int (fun i -> pool_buf_size := Some i), + " maximum buffer pool size" ); + "--buf-size", Arg.Set_int buf_size, " buffer size"; + "--max-conns", Arg.Set_int max_conns, " maximum number of connections"; + "--addr", Arg.Set_string addr, " binding address"; + ]) + (fun _ -> raise (Arg.Bad "")) + "echo [option]*"; + + let@ stdenv = Eio_main.run in + let@ sw = Eio.Switch.run ~name:"main" in + let server = + Tiny_httpd_eio.create ~addr:!addr ~port:!port_ ~max_connections:!max_conns + ~buf_size:!buf_size ?max_buf_pool_size:!pool_buf_size ~stdenv ~sw () + in + + if Trace.enabled () then ( + Tiny_httpd.Server.add_middleware server ~stage:(`Stage 1) middleware_trace; + + (* fiber that emits metrics *) + Eio.Fiber.fork_daemon ~sw (fun () -> + while Eio.Switch.get_error sw |> Option.is_none do + Trace.counter_int "http.active-conns" + (Server.active_connections server); + Eio_unix.sleep 0.5 + done; + `Stop_daemon) + ); + + Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16 * 1024) server; + let m_stats, get_stats = middleware_stat () in + Server.add_middleware server ~stage:(`Stage 1) m_stats; + + (* say hello *) + Server.add_route_handler ~meth:`GET server + Route.(exact "hello" @/ string @/ return) + (fun name _req -> Response.make_string (Ok ("hello " ^ name ^ "!\n"))); + + (* compressed file access *) + Server.add_route_handler ~meth:`GET server + Route.(exact "zcat" @/ string_urlencoded @/ return) + (fun path _req -> + let ic = open_in path in + let str = IO.Input.of_in_channel ic in + let mime_type = + try + let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" path) in + try + let s = [ "Content-Type", String.trim (input_line p) ] in + ignore @@ Unix.close_process_in p; + s + with _ -> + ignore @@ Unix.close_process_in p; + [] + with _ -> [] + in + Response.make_stream ~headers:mime_type (Ok str)); + + (* echo request *) + Server.add_route_handler server + Route.(exact "echo" @/ return) + (fun req -> + let q = + Request.query req + |> List.map (fun (k, v) -> Printf.sprintf "%S = %S" k v) + |> String.concat ";" + in + Response.make_string + (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." Request.pp req q))); + + (* file upload *) + Server.add_route_handler_stream ~meth:`PUT server + Route.(exact "upload" @/ string @/ return) + (fun path req -> + Log.debug (fun k -> + k "start upload %S, headers:\n%s\n\n%!" path + (Format.asprintf "%a" Headers.pp (Request.headers req))); + try + let oc = open_out @@ "/tmp/" ^ path in + IO.Input.to_chan oc req.Request.body; + flush oc; + Response.make_string (Ok "uploaded file") + with e -> + Response.fail ~code:500 "couldn't upload file: %s" + (Printexc.to_string e)); + + (* protected by login *) + Server.add_route_handler server + Route.(exact "protected" @/ return) + (fun req -> + let ok = + match Request.get_header req "authorization" with + | Some v -> + Log.debug (fun k -> k "authenticate with %S" v); + v = "Basic " ^ base64 "user:foobar" + | None -> false + in + if ok then ( + (* FIXME: a logout link *) + let s = + "

hello, this is super secret!

log out" + in + Response.make_string (Ok s) + ) else ( + let headers = + Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"") + in + Response.fail ~code:401 ~headers "invalid" + )); + + (* logout *) + Server.add_route_handler server + Route.(exact "logout" @/ return) + (fun _req -> Response.fail ~code:401 "logged out"); + + (* stats *) + Server.add_route_handler server + Route.(exact "stats" @/ return) + (fun _req -> + let stats = get_stats () in + Response.make_string @@ Ok stats); + + Server.add_route_handler server + Route.(exact "alice" @/ return) + (fun _req -> Response.make_string (Ok alice_text)); + + Server.add_route_handler ~meth:`HEAD server + Route.(exact "head" @/ return) + (fun _req -> + Response.make_void ~code:200 ~headers:[ "x-hello", "world" ] ()); + + (* VFS *) + Tiny_httpd.Dir.add_vfs server + ~config: + (Tiny_httpd.Dir.config ~download:true + ~dir_behavior:Tiny_httpd.Dir.Index_or_lists ()) + ~vfs:Vfs.vfs ~prefix:"vfs"; + + setup_upload server; + + (* main page *) + Server.add_route_handler server + Route.(return) + (fun _req -> + let open Tiny_httpd_html in + let h = + html [] + [ + head [] [ title [] [ txt "index of echo" ] ]; + body [] + [ + h3 [] [ txt "welcome!" ]; + p [] [ b [] [ txt "endpoints are:" ] ]; + ul [] + [ + li [] [ pre [] [ txt "/hello/:name (GET)" ] ]; + li [] + [ + pre [] + [ + a [ A.href "/echo/" ] [ txt "echo" ]; + txt " echo back query"; + ]; + ]; + li [] + [ pre [] [ txt "/upload/:path (PUT) to upload a file" ] ]; + li [] + [ + pre [] + [ + txt + "/zcat/:path (GET) to download a file (deflate \ + transfer-encoding)"; + ]; + ]; + li [] + [ + pre [] + [ + a [ A.href "/stats/" ] [ txt "/stats/" ]; + txt " (GET) to access statistics"; + ]; + ]; + li [] + [ + pre [] + [ + a [ A.href "/vfs/" ] [ txt "/vfs" ]; + txt " (GET) to access a VFS embedded in the binary"; + ]; + ]; + li [] + [ + pre [] + [ + a [ A.href "/protected" ] [ txt "/protected" ]; + txt + " (GET) to see a protected page (login: user, \ + password: foobar)"; + ]; + ]; + li [] + [ + pre [] + [ + a [ A.href "/logout" ] [ txt "/logout" ]; + txt " (POST) to log out"; + ]; + ]; + li [] + [ + form + [ + A.action "/upload"; + A.enctype "multipart/form-data"; + A.target "_self"; + A.method_ "POST"; + ] + [ + label [] [ txt "my beautiful form" ]; + input [ A.type_ "file"; A.name "file1" ]; + input [ A.type_ "file"; A.name "file2" ]; + input + [ + A.type_ "text"; + A.name "a"; + A.placeholder "text A"; + ]; + input + [ + A.type_ "text"; + A.name "b"; + A.placeholder "text B"; + ]; + input [ A.type_ "submit" ]; + ]; + ]; + ]; + ]; + ] + in + let s = to_string_top h in + Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok s); + + Printf.printf "listening on http://%s:%d\n%!" (Server.addr server) + (Server.port server); + match Server.run server with + | Ok () -> () + | Error e -> raise e From 55dac0fa0bc22962d508e083e2869f0f27c4a158 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 1 May 2025 15:43:48 -0400 Subject: [PATCH 03/18] CI --- .github/workflows/gh-pages.yml | 4 ++-- .github/workflows/main.yml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml index 51187fd9..29ef55e1 100644 --- a/.github/workflows/gh-pages.yml +++ b/.github/workflows/gh-pages.yml @@ -20,10 +20,10 @@ jobs: allow-prerelease-opam: true - name: Deps - run: opam install odig tiny_httpd tiny_httpd_camlzip + run: opam install odig tiny_httpd tiny_httpd_camlzip tiny_httpd_eio - name: Build - run: opam exec -- odig odoc --cache-dir=_doc/ tiny_httpd tiny_httpd_camlzip + run: opam exec -- odig odoc --cache-dir=_doc/ tiny_httpd tiny_httpd_camlzip tiny_httpd_eio - name: Deploy uses: peaceiris/actions-gh-pages@v3 diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 3663bd1c..fdb02064 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -38,7 +38,7 @@ jobs: - run: opam install ./tiny_httpd.opam ./tiny_httpd_camlzip.opam --deps-only --with-test - - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip + - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio - run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd if: ${{ matrix.os == 'ubuntu-latest' }} @@ -50,4 +50,4 @@ jobs: - run: opam install logs magic-mime -y - - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip + - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio From a11ed88522e931e07b6f172738e34fca49a55b5a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 1 May 2025 15:44:51 -0400 Subject: [PATCH 04/18] chore: bounds on eio --- dune-project | 2 +- tiny_httpd_eio.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dune-project b/dune-project index 7c4a4a12..fc741051 100644 --- a/dune-project +++ b/dune-project @@ -45,6 +45,6 @@ (synopsis "Use eio for tiny_httpd") (depends (tiny_httpd (= :version)) - eio + (eio (and (>= 1.0) (< 2.0))) (logs :with-test) (odoc :with-doc))) diff --git a/tiny_httpd_eio.opam b/tiny_httpd_eio.opam index cdc15a35..15b2a090 100644 --- a/tiny_httpd_eio.opam +++ b/tiny_httpd_eio.opam @@ -10,7 +10,7 @@ bug-reports: "https://github.com/c-cube/tiny_httpd/issues" depends: [ "dune" {>= "3.2"} "tiny_httpd" {= version} - "eio" + "eio" {>= "1.0" & < "2.0"} "logs" {with-test} "odoc" {with-doc} ] From 94ed68c30c6757701ee8d72805a2fd7e69e5bb6a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 15:13:25 -0500 Subject: [PATCH 05/18] fix warnings --- examples/echo_eio.ml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/examples/echo_eio.ml b/examples/echo_eio.ml index 5905fe57..c2f2067e 100644 --- a/examples/echo_eio.ml +++ b/examples/echo_eio.ml @@ -69,12 +69,10 @@ let middleware_stat () : Server.Middleware.t * (unit -> string) = let middleware_trace : Server.Middleware.t = fun (h : Server.Middleware.handler) req ~resp -> - let _sp = - Trace.enter_manual_toplevel_span ~__FILE__ ~__LINE__ "http.handle" - in + let _sp = Trace.enter_span ~__FILE__ ~__LINE__ "http.handle" in let new_resp (r : Response.t) = - Trace.add_data_to_manual_span _sp [ "http.code", `Int r.code ]; - Trace.exit_manual_span _sp; + Trace.add_data_to_span _sp [ "http.code", `Int r.code ]; + Trace.exit_span _sp; resp r in h req ~resp:new_resp From 46d30392b984485de37547e706ed2907102e391a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 15:23:18 -0500 Subject: [PATCH 06/18] delete gh-pages action --- .github/workflows/gh-pages.yml | 36 ---------------------------------- 1 file changed, 36 deletions(-) delete mode 100644 .github/workflows/gh-pages.yml diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml deleted file mode 100644 index 29ef55e1..00000000 --- a/.github/workflows/gh-pages.yml +++ /dev/null @@ -1,36 +0,0 @@ -name: github pages - -on: - push: - branches: - - main - -jobs: - deploy: - runs-on: ubuntu-latest - steps: - - name: Checkout code - uses: actions/checkout@v3 - - - name: Use OCaml - uses: ocaml/setup-ocaml@v3 - with: - ocaml-compiler: 5.03.x - dune-cache: true - allow-prerelease-opam: true - - - name: Deps - run: opam install odig tiny_httpd tiny_httpd_camlzip tiny_httpd_eio - - - name: Build - run: opam exec -- odig odoc --cache-dir=_doc/ tiny_httpd tiny_httpd_camlzip tiny_httpd_eio - - - name: Deploy - uses: peaceiris/actions-gh-pages@v3 - with: - github_token: ${{ secrets.GITHUB_TOKEN }} - publish_dir: ./_doc/html - destination_dir: . - enable_jekyll: false - #keep_files: true - From 93c08944bfb03e5c389a875be6d6092837a41d6a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 15:23:22 -0500 Subject: [PATCH 07/18] fix CI --- .github/workflows/format.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index 647e1256..29e9129c 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -6,6 +6,7 @@ on: branches: - main +jobs: format: name: format strategy: From 98385b43a90e841be684348d20579875579f2e27 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 15:39:56 -0500 Subject: [PATCH 08/18] format --- examples/dune | 8 ++++---- src/eio/dune | 12 +++++------- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/examples/dune b/examples/dune index 78350f9a..5e139283 100644 --- a/examples/dune +++ b/examples/dune @@ -73,10 +73,10 @@ ; produce an embedded FS (library - (name echo_vfs) - (modules vfs) - (wrapped false) - (libraries tiny_httpd)) + (name echo_vfs) + (modules vfs) + (wrapped false) + (libraries tiny_httpd)) (rule (targets vfs.ml) diff --git a/src/eio/dune b/src/eio/dune index 37431aba..11100ed1 100644 --- a/src/eio/dune +++ b/src/eio/dune @@ -1,8 +1,6 @@ - (library - (name tiny_httpd_eio) - (public_name tiny_httpd_eio) - (synopsis "An EIO-based backend for Tiny_httpd") - (flags :standard -safe-string -warn-error -a+8) - (libraries tiny_httpd eio eio.unix)) - + (name tiny_httpd_eio) + (public_name tiny_httpd_eio) + (synopsis "An EIO-based backend for Tiny_httpd") + (flags :standard -safe-string -warn-error -a+8) + (libraries tiny_httpd eio eio.unix)) From 5e32ce7bccd1bcac7e2efe3e9e00ebc2c8769dfd Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 15:46:31 -0500 Subject: [PATCH 09/18] fix dune --- src/eio/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/eio/dune b/src/eio/dune index 11100ed1..fafdcaf3 100644 --- a/src/eio/dune +++ b/src/eio/dune @@ -3,4 +3,4 @@ (public_name tiny_httpd_eio) (synopsis "An EIO-based backend for Tiny_httpd") (flags :standard -safe-string -warn-error -a+8) - (libraries tiny_httpd eio eio.unix)) + (libraries tiny_httpd eio eio_posix)) From f0aadc0307fa870e568788b853d9d60b68342b18 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 15:54:03 -0500 Subject: [PATCH 10/18] disable warning --- src/ws/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ws/dune b/src/ws/dune index 36e984dd..12ef15ff 100644 --- a/src/ws/dune +++ b/src/ws/dune @@ -51,7 +51,7 @@ (public_name tiny_httpd.ws) (synopsis "Websockets for tiny_httpd") (private_modules common_ws_ utils_) - (flags :standard -open Tiny_httpd_core) + (flags :standard -w -32 -open Tiny_httpd_core) (foreign_stubs (language c) (names tiny_httpd_ws_stubs) From 28f7ddd74fdc1fea356407b08d2a8a2ce3cee75a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 20:30:13 +0000 Subject: [PATCH 11/18] fix(eio): address review feedback - Add closed flag to ic_of_flow/oc_of_flow to prevent double-release of pool cstructs and double-shutdown - Enforce max_connections with Eio.Semaphore to limit concurrent connections - Fix port 0 detection using Eio.Net.listening_addr to return actual port - Use pool_size for cstruct pool max_size (was computed but unused) - Set TCP_NODELAY on accepted connections for low latency --- src/eio/tiny_httpd_eio.ml | 53 ++++++++++++++++++++++++++++----------- 1 file changed, 38 insertions(+), 15 deletions(-) diff --git a/src/eio/tiny_httpd_eio.ml b/src/eio/tiny_httpd_eio.ml index e58d1b6b..61060a97 100644 --- a/src/eio/tiny_httpd_eio.ml +++ b/src/eio/tiny_httpd_eio.ml @@ -31,8 +31,10 @@ let eio_sock_addr_to_unix (a : Eio.Net.Sockaddr.stream) : Unix.sockaddr = | `Tcp (h, p) -> Unix.ADDR_INET (eio_ipaddr_to_unix h, p) | `Unix s -> Unix.ADDR_UNIX s -let ic_of_flow ~buf_pool:ic_pool (flow : _ Eio.Net.stream_socket) : IO.Input.t = +let ic_of_flow ~closed ~buf_pool:ic_pool (flow : _ Eio.Net.stream_socket) : + IO.Input.t = let cstruct = Pool.Raw.acquire ic_pool in + let sent_shutdown = ref false in object inherit Iostream.In_buf.t_from_refill () @@ -52,15 +54,20 @@ let ic_of_flow ~buf_pool:ic_pool (flow : _ Eio.Net.stream_socket) : IO.Input.t = sl.len <- n method close () = - Pool.Raw.release ic_pool cstruct; - Eio.Flow.shutdown flow `Receive + if not !closed then ( + closed := true; + Pool.Raw.release ic_pool cstruct); + if not !sent_shutdown then ( + sent_shutdown := true; + Eio.Flow.shutdown flow `Receive) end -let oc_of_flow ~buf_pool:oc_pool (flow : _ Eio.Net.stream_socket) : IO.Output.t - = +let oc_of_flow ~closed ~buf_pool:oc_pool (flow : _ Eio.Net.stream_socket) : + IO.Output.t = (* write buffer *) let wbuf : Cstruct.t = Pool.Raw.acquire oc_pool in let offset = ref 0 in + let sent_shutdown = ref false in object (self) method flush () : unit = @@ -91,8 +98,12 @@ let oc_of_flow ~buf_pool:oc_pool (flow : _ Eio.Net.stream_socket) : IO.Output.t if !offset = Cstruct.length wbuf then self#flush () method close () = - Pool.Raw.release oc_pool wbuf; - Eio.Flow.shutdown flow `Send + if not !closed then ( + closed := true; + Pool.Raw.release oc_pool wbuf); + if not !sent_shutdown then ( + sent_shutdown := true; + Eio.Flow.shutdown flow `Send) end let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size @@ -127,7 +138,7 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size | None -> min 4096 (max_connections * 2) let cstruct_pool = - Pool.create ~max_size:max_connections + Pool.create ~max_size:pool_size ~mk_item:(fun () -> Cstruct.create buf_size) () @@ -137,6 +148,7 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size (fun ~after_init ~handle () : unit -> let running = Atomic.make true in let active_conns = Atomic.make 0 in + let sem = Eio.Semaphore.make max_connections in Eio.Switch.on_release sw (fun () -> Atomic.set running false); let net = Eio.Stdenv.net stdenv in @@ -148,6 +160,13 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size sockaddr in + (* Resolve actual address/port (important for port 0) *) + let actual_addr, actual_port = + match Eio.Net.listening_addr sock with + | `Tcp (_, p) -> addr, p + | `Unix s -> Printf.sprintf "unix:%s" s, 0 + in + let tcp_server : IO.TCP_server.t = { running = (fun () -> Atomic.get running); @@ -155,10 +174,7 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size (fun () -> Atomic.set running false; Eio.Switch.fail sw Exit); - endpoint = - (fun () -> - (* TODO: find the real port *) - addr, port); + endpoint = (fun () -> actual_addr, actual_port); active_connections = (fun () -> Atomic.get active_conns); } in @@ -172,15 +188,22 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size k "error in client handler: %s" (Printexc.to_string exn))) sock (fun flow client_addr -> + Eio.Semaphore.acquire sem; + Eio_unix.Fd.use_exn "setsockopt" + (Eio_unix.Net.fd flow) (fun fd -> + Unix.setsockopt fd Unix.TCP_NODELAY true); Atomic.incr active_conns; let@ () = Fun.protect ~finally:(fun () -> Log.debug (fun k -> k "Tiny_httpd_eio: client handler returned"); - Atomic.decr active_conns) + Atomic.decr active_conns; + Eio.Semaphore.release sem) in - let ic = ic_of_flow ~buf_pool:cstruct_pool flow in - let oc = oc_of_flow ~buf_pool:cstruct_pool flow in + let ic_closed = ref false in + let oc_closed = ref false in + let ic = ic_of_flow ~closed:ic_closed ~buf_pool:cstruct_pool flow in + let oc = oc_of_flow ~closed:oc_closed ~buf_pool:cstruct_pool flow in Log.debug (fun k -> k "handling client on %a…" Eio.Net.Sockaddr.pp client_addr); From 6c3e705df5b929752ad4cbb332efd630fe6dff39 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 20:41:25 +0000 Subject: [PATCH 12/18] ci: only build/test eio on OCaml 5.x --- .github/workflows/main.yml | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index fdb02064..4fbd4073 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -38,7 +38,15 @@ jobs: - run: opam install ./tiny_httpd.opam ./tiny_httpd_camlzip.opam --deps-only --with-test - - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio + - name: Build (OCaml 4.x) + run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip + if: ${{ !startsWith(matrix.ocaml-compiler, '5.') }} + + - name: Build (OCaml 5.x, includes eio) + run: | + opam install ./tiny_httpd_eio.opam --deps-only --with-test + opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio + if: ${{ startsWith(matrix.ocaml-compiler, '5.') }} - run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd if: ${{ matrix.os == 'ubuntu-latest' }} @@ -50,4 +58,10 @@ jobs: - run: opam install logs magic-mime -y - - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio + - name: Final build (OCaml 4.x) + run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip + if: ${{ !startsWith(matrix.ocaml-compiler, '5.') }} + + - name: Final build (OCaml 5.x, includes eio) + run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio + if: ${{ startsWith(matrix.ocaml-compiler, '5.') }} From 97c4e4dc08d4465ea7d7e57364daae780c07140d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 20:50:43 +0000 Subject: [PATCH 13/18] chore: upgrade qcheck to 0.91, fix deprecation warnings - small_list -> list_small - bytes_of_size -> bytes_size - small_nat -> nat_small - prefix unused Frame_type constants with underscore --- dune-project | 2 +- src/ws/tiny_httpd_ws.ml | 10 +++++----- tests/unit/t_util.ml | 2 +- tests/unit/ws/t_ws_q.ml | 6 +++--- tiny_httpd.opam | 2 +- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/dune-project b/dune-project index fc741051..c05a4cca 100644 --- a/dune-project +++ b/dune-project @@ -28,7 +28,7 @@ (logs :with-test) (conf-libcurl :with-test) (ptime :with-test) - (qcheck-core (and (>= 0.9) :with-test)))) + (qcheck-core (and (>= 0.91) :with-test)))) (package (name tiny_httpd_camlzip) diff --git a/src/ws/tiny_httpd_ws.ml b/src/ws/tiny_httpd_ws.ml index 3c4fdf03..4979549d 100644 --- a/src/ws/tiny_httpd_ws.ml +++ b/src/ws/tiny_httpd_ws.ml @@ -26,11 +26,11 @@ 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 _continuation : t = 0 + let _text : t = 1 let binary : t = 2 - let close : t = 8 - let ping : t = 9 + let _close : t = 8 + let _ping : t = 9 let pong : t = 10 let show = function @@ -132,7 +132,7 @@ module Writer = struct () (** Max fragment size: send 16 kB at a time *) - let max_fragment_size = 16 * 1024 + let _max_fragment_size = 16 * 1024 let[@inline never] really_output_buf_ (self : t) = self.header.fin <- true; diff --git a/tests/unit/t_util.ml b/tests/unit/t_util.ml index 7af8b87e..b3a2e066 100644 --- a/tests/unit/t_util.ml +++ b/tests/unit/t_util.ml @@ -40,7 +40,7 @@ let () = assert_eq (Ok [ "foo", "bar" ]) (U.parse_query "yolo#foo=bar") let () = add_qcheck @@ QCheck.Test.make ~name:__LOC__ ~long_factor:20 ~count:1_000 - Q.(small_list (pair string string)) + Q.(list_small (pair string string)) (fun l -> List.iter (fun (a, b) -> diff --git a/tests/unit/ws/t_ws_q.ml b/tests/unit/ws/t_ws_q.ml index 1e17cb50..1776fd02 100644 --- a/tests/unit/ws/t_ws_q.ml +++ b/tests/unit/ws/t_ws_q.ml @@ -14,9 +14,9 @@ let () = @@ QCheck.Test.make ~count:10_000 Q.( triple - (bytes_of_size (Gen.return 4)) - (option small_nat) - (bytes_of_size Gen.(0 -- 6000)) + (bytes_size (Gen.return 4)) + (option nat_small) + (bytes_size Gen.(0 -- 6000)) (* |> Q.add_stat ("b.size", fun (_k, b) -> Bytes.length b) *) |> Q.add_shrink_invariant (fun (k, _, _) -> Bytes.length k = 4)) (fun (key, mask_offset, b) -> diff --git a/tiny_httpd.opam b/tiny_httpd.opam index e4048cb7..7fbbe020 100644 --- a/tiny_httpd.opam +++ b/tiny_httpd.opam @@ -22,7 +22,7 @@ depends: [ "logs" {with-test} "conf-libcurl" {with-test} "ptime" {with-test} - "qcheck-core" {>= "0.9" & with-test} + "qcheck-core" {>= "0.91" & with-test} ] depopts: [ "logs" From 32421a26bc66935eb4c9e63055bb090196d17b97 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 16:08:56 -0500 Subject: [PATCH 14/18] go back to eio.unix --- dune-project | 1 + src/eio/dune | 2 +- tiny_httpd_eio.opam | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/dune-project b/dune-project index c05a4cca..5eaf279c 100644 --- a/dune-project +++ b/dune-project @@ -46,5 +46,6 @@ (depends (tiny_httpd (= :version)) (eio (and (>= 1.0) (< 2.0))) + base-unix (logs :with-test) (odoc :with-doc))) diff --git a/src/eio/dune b/src/eio/dune index fafdcaf3..11100ed1 100644 --- a/src/eio/dune +++ b/src/eio/dune @@ -3,4 +3,4 @@ (public_name tiny_httpd_eio) (synopsis "An EIO-based backend for Tiny_httpd") (flags :standard -safe-string -warn-error -a+8) - (libraries tiny_httpd eio eio_posix)) + (libraries tiny_httpd eio eio.unix)) diff --git a/tiny_httpd_eio.opam b/tiny_httpd_eio.opam index 15b2a090..51f27557 100644 --- a/tiny_httpd_eio.opam +++ b/tiny_httpd_eio.opam @@ -11,6 +11,7 @@ depends: [ "dune" {>= "3.2"} "tiny_httpd" {= version} "eio" {>= "1.0" & < "2.0"} + "base-unix" "logs" {with-test} "odoc" {with-doc} ] From ffdcc1139c90110c8326fcf9bdeb593199b3a8ca Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 16:13:24 -0500 Subject: [PATCH 15/18] format --- src/eio/tiny_httpd_eio.ml | 25 ++++++++++++++++--------- src/ws/dune | 2 +- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/eio/tiny_httpd_eio.ml b/src/eio/tiny_httpd_eio.ml index 61060a97..85a2c68d 100644 --- a/src/eio/tiny_httpd_eio.ml +++ b/src/eio/tiny_httpd_eio.ml @@ -56,10 +56,12 @@ let ic_of_flow ~closed ~buf_pool:ic_pool (flow : _ Eio.Net.stream_socket) : method close () = if not !closed then ( closed := true; - Pool.Raw.release ic_pool cstruct); + Pool.Raw.release ic_pool cstruct + ); if not !sent_shutdown then ( sent_shutdown := true; - Eio.Flow.shutdown flow `Receive) + Eio.Flow.shutdown flow `Receive + ) end let oc_of_flow ~closed ~buf_pool:oc_pool (flow : _ Eio.Net.stream_socket) : @@ -100,10 +102,12 @@ let oc_of_flow ~closed ~buf_pool:oc_pool (flow : _ Eio.Net.stream_socket) : method close () = if not !closed then ( closed := true; - Pool.Raw.release oc_pool wbuf); + Pool.Raw.release oc_pool wbuf + ); if not !sent_shutdown then ( sent_shutdown := true; - Eio.Flow.shutdown flow `Send) + Eio.Flow.shutdown flow `Send + ) end let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size @@ -189,9 +193,8 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size sock (fun flow client_addr -> Eio.Semaphore.acquire sem; - Eio_unix.Fd.use_exn "setsockopt" - (Eio_unix.Net.fd flow) (fun fd -> - Unix.setsockopt fd Unix.TCP_NODELAY true); + Eio_unix.Fd.use_exn "setsockopt" (Eio_unix.Net.fd flow) + (fun fd -> Unix.setsockopt fd Unix.TCP_NODELAY true); Atomic.incr active_conns; let@ () = Fun.protect ~finally:(fun () -> @@ -202,8 +205,12 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size in let ic_closed = ref false in let oc_closed = ref false in - let ic = ic_of_flow ~closed:ic_closed ~buf_pool:cstruct_pool flow in - let oc = oc_of_flow ~closed:oc_closed ~buf_pool:cstruct_pool flow in + let ic = + ic_of_flow ~closed:ic_closed ~buf_pool:cstruct_pool flow + in + let oc = + oc_of_flow ~closed:oc_closed ~buf_pool:cstruct_pool flow + in Log.debug (fun k -> k "handling client on %a…" Eio.Net.Sockaddr.pp client_addr); diff --git a/src/ws/dune b/src/ws/dune index 12ef15ff..5fee1aaa 100644 --- a/src/ws/dune +++ b/src/ws/dune @@ -51,7 +51,7 @@ (public_name tiny_httpd.ws) (synopsis "Websockets for tiny_httpd") (private_modules common_ws_ utils_) - (flags :standard -w -32 -open Tiny_httpd_core) + (flags :standard -w -32 -open Tiny_httpd_core) (foreign_stubs (language c) (names tiny_httpd_ws_stubs) From 2a3cfa015abe4d763b9409e7350adfeb409a3028 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 16:14:49 -0500 Subject: [PATCH 16/18] CI --- .github/workflows/main.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 4fbd4073..26978b46 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -44,7 +44,7 @@ jobs: - name: Build (OCaml 5.x, includes eio) run: | - opam install ./tiny_httpd_eio.opam --deps-only --with-test + opam install ./tiny_httpd.opam ./tiny_httpd_eio.opam --deps-only --with-test opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio if: ${{ startsWith(matrix.ocaml-compiler, '5.') }} From 3b631b7e4c225c96d2edd83aba883c38ceb986fc Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 21:22:39 +0000 Subject: [PATCH 17/18] eio: fix semaphore acquisition, graceful stop, and time source - Acquire semaphore BEFORE spawning handler fiber: replace Eio.Net.accept_fork with manual accept + Semaphore.acquire + Fiber.fork so we bound the number of in-flight fibers rather than spawning unlimited fibers that all block on the semaphore. - Graceful stop: remove Eio.Switch.fail sw Exit from stop(), just set running to false so existing handlers can complete naturally instead of being cancelled immediately. - Replace Unix.gettimeofday with Eio.Time.now clock to use the Eio clock abstraction instead of direct Unix calls. --- src/eio/tiny_httpd_eio.ml | 39 ++++++++++++++++++++++----------------- 1 file changed, 22 insertions(+), 17 deletions(-) diff --git a/src/eio/tiny_httpd_eio.ml b/src/eio/tiny_httpd_eio.ml index 61060a97..85c8d4c9 100644 --- a/src/eio/tiny_httpd_eio.ml +++ b/src/eio/tiny_httpd_eio.ml @@ -129,7 +129,8 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size let module M = struct let init_addr () = addr let init_port () = port - let get_time_s () = Unix.gettimeofday () + let clock = Eio.Stdenv.clock stdenv + let get_time_s () = Eio.Time.now clock let max_connections = get_max_connection_ ?max_connections () let pool_size = @@ -172,8 +173,7 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size running = (fun () -> Atomic.get running); stop = (fun () -> - Atomic.set running false; - Eio.Switch.fail sw Exit); + Atomic.set running false); endpoint = (fun () -> actual_addr, actual_port); active_connections = (fun () -> Atomic.get active_conns); } @@ -182,28 +182,33 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size after_init tcp_server; while Atomic.get running do - Eio.Net.accept_fork ~sw - ~on_error:(fun exn -> - Log.error (fun k -> - k "error in client handler: %s" (Printexc.to_string exn))) - sock - (fun flow client_addr -> - Eio.Semaphore.acquire sem; - Eio_unix.Fd.use_exn "setsockopt" - (Eio_unix.Net.fd flow) (fun fd -> - Unix.setsockopt fd Unix.TCP_NODELAY true); - Atomic.incr active_conns; + match Eio.Net.accept ~sw sock with + | exception (Eio.Cancel.Cancelled _ | Eio.Io _) when not (Atomic.get running) -> + (* Socket closed or switch cancelled during shutdown; exit loop *) + () + | conn, client_addr -> + (* Acquire semaphore BEFORE spawning a fiber so we + bound the number of in-flight fibers. *) + Eio.Semaphore.acquire sem; + Eio.Fiber.fork ~sw (fun () -> let@ () = Fun.protect ~finally:(fun () -> Log.debug (fun k -> k "Tiny_httpd_eio: client handler returned"); Atomic.decr active_conns; - Eio.Semaphore.release sem) + Eio.Semaphore.release sem; + Eio.Flow.close conn) in + (try + Eio_unix.Fd.use_exn "setsockopt" + (Eio_unix.Net.fd conn) (fun fd -> + Unix.setsockopt fd Unix.TCP_NODELAY true) + with Unix.Unix_error _ -> ()); + Atomic.incr active_conns; let ic_closed = ref false in let oc_closed = ref false in - let ic = ic_of_flow ~closed:ic_closed ~buf_pool:cstruct_pool flow in - let oc = oc_of_flow ~closed:oc_closed ~buf_pool:cstruct_pool flow in + let ic = ic_of_flow ~closed:ic_closed ~buf_pool:cstruct_pool conn in + let oc = oc_of_flow ~closed:oc_closed ~buf_pool:cstruct_pool conn in Log.debug (fun k -> k "handling client on %a…" Eio.Net.Sockaddr.pp client_addr); From c6468dced849bc4c145c3533e46902f247ca163b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 15 Feb 2026 21:26:25 +0000 Subject: [PATCH 18/18] eio: add 60s shutdown backstop, protect Flow.close from raising --- src/eio/tiny_httpd_eio.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/eio/tiny_httpd_eio.ml b/src/eio/tiny_httpd_eio.ml index 85c8d4c9..d7ddba57 100644 --- a/src/eio/tiny_httpd_eio.ml +++ b/src/eio/tiny_httpd_eio.ml @@ -173,7 +173,13 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size running = (fun () -> Atomic.get running); stop = (fun () -> - Atomic.set running false); + Atomic.set running false; + (* Backstop: fail the switch after 60s if handlers don't complete *) + Eio.Fiber.fork_daemon ~sw (fun () -> + Eio.Time.sleep clock 60.0; + if Eio.Switch.get_error sw |> Option.is_none then + Eio.Switch.fail sw Exit; + `Stop_daemon)); endpoint = (fun () -> actual_addr, actual_port); active_connections = (fun () -> Atomic.get active_conns); } @@ -197,7 +203,7 @@ let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size k "Tiny_httpd_eio: client handler returned"); Atomic.decr active_conns; Eio.Semaphore.release sem; - Eio.Flow.close conn) + (try Eio.Flow.close conn with Eio.Io _ -> ())) in (try Eio_unix.Fd.use_exn "setsockopt"