doc

can be replaced with a proper cooperative lock

.ocamlformat

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

CHANGES.md

@@ -1,4 +1,23 @@
 
+## 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

dune-project

@@ -4,7 +4,7 @@
 
 (authors c-cube)
 (maintainers c-cube)
-(version 0.18)
+(version 0.19)
 (source (github c-cube/tiny_httpd))
 (homepage https://github.com/c-cube/tiny_httpd/)
 (license MIT)

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

@@ -4,24 +4,46 @@ type t = (string * string) list
 
 let empty = []
 
-let contains name headers =
-  let name' = String.lowercase_ascii name in
-  List.exists (fun (n, _) -> name' = n) headers
+(* [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
 
-let get_exn ?(f = fun x -> x) x h =
-  let x' = String.lowercase_ascii x in
-  List.assoc x' h |> f
+(** 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 =
-  let x' = String.lowercase_ascii x in
-  List.filter (fun (k, _) -> k <> x') h
+let remove x h = List.filter (fun (k, _) -> not (equal_name_ k x)) h
 
 let set x y h =
-  let x' = String.lowercase_ascii x in
-  (x', y) :: List.filter (fun (k, _) -> k <> x') h
+  let 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
@@ -76,6 +98,6 @@ let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
         | Error msg ->
           bad_reqf 400 "invalid header line: %s\nline is: %S" msg line
       in
-      loop ((String.lowercase_ascii k, v) :: acc)
+      loop ((k, v) :: acc)
   in
   loop []

src/core/headers.mli

@@ -32,8 +32,9 @@ val contains : string -> t -> bool
 val pp : Format.formatter -> t -> unit
 (** Pretty print the headers. *)
 
-val parse_ : buf:Buf.t -> IO.Input.t -> t
 (**/*)
 
+val parse_ : buf:Buf.t -> IO.Input.t -> t
 val parse_line_ : string -> (string * string, string) result
+
 (**/*)

src/core/pool.ml

@@ -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/response.ml

@@ -15,7 +15,11 @@ let set_code code self = { self with code }
 let make_raw ?(headers = []) ~code body : t =
   (* add content length to response *)
   let headers =
-    Headers.set "Content-Length" (string_of_int (String.length body)) headers
+    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 }
 

src/core/route.ml

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

src/core/route.mli

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

src/core/server.ml

@@ -15,7 +15,6 @@ module Head_middleware = struct
   type t = { handle: 'a. 'a Request.t -> 'a Request.t }
 
   let trivial = { handle = Fun.id }
-  let[@inline] apply (self : t) req = self.handle req
   let[@inline] apply' req (self : t) = self.handle req
 
   let to_middleware (self : t) : Middleware.t =

src/html/gen/gentags.ml

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

src/ws/tiny_httpd_ws.ml

@@ -1,5 +1,26 @@
 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
@@ -52,10 +73,10 @@ module Writer = struct
     mutable offset: int;  (** number of bytes already in [buf] *)
     oc: IO.Output.t;
     mutable closed: bool;
-    mutex: Mutex.t;
+    mutex: With_lock.t;
   }
 
-  let create ?(buf_size = 16 * 1024) ~oc () : t =
+  let create ?(buf_size = 16 * 1024) ~with_lock ~oc () : t =
     {
       header = Header.create ();
       header_buf = Bytes.create 16;
@@ -63,19 +84,9 @@ module Writer = struct
       offset = 0;
       oc;
       closed = false;
-      mutex = Mutex.create ();
+      mutex = with_lock;
     }
 
-  let[@inline] with_mutex_ (self : t) f =
-    Mutex.lock self.mutex;
-    try
-      let x = f () in
-      Mutex.unlock self.mutex;
-      x
-    with e ->
-      Mutex.unlock self.mutex;
-      raise e
-
   let[@inline] close self = self.closed <- true
   let int_of_bool : bool -> int = Obj.magic
 
@@ -142,7 +153,7 @@ module Writer = struct
     if self.offset = Bytes.length self.buf then really_output_buf_ self
 
   let send_pong (self : t) : unit =
-    let@ () = with_mutex_ self in
+    let@ () = self.mutex.with_lock in
     self.header.fin <- true;
     self.header.ty <- Frame_type.pong;
     self.header.payload_len <- 0;
@@ -151,7 +162,7 @@ module Writer = struct
     write_header_ self
 
   let output_char (self : t) c : unit =
-    let@ () = with_mutex_ self in
+    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;
@@ -161,7 +172,7 @@ module Writer = struct
     if cap = 1 then really_output_buf_ self
 
   let output (self : t) buf i len : unit =
-    let@ () = with_mutex_ self in
+    let@ () = self.mutex.with_lock in
     let i = ref i in
     let len = ref len in
     while !len > 0 do
@@ -179,7 +190,7 @@ module Writer = struct
     flush_if_full self
 
   let flush self : unit =
-    let@ () = with_mutex_ self in
+    let@ () = self.mutex.with_lock in
     flush_ self
 end
 
@@ -187,8 +198,8 @@ module Reader = struct
   type state =
     | Begin  (** At the beginning of a frame *)
     | Reading_frame of { mutable remaining_bytes: int; mutable num_read: int }
-        (** Currently reading the payload of a frame with [remaining_bytes]
-        left to read from the underlying [ic] *)
+        (** Currently reading the payload of a frame with [remaining_bytes] left
+            to read from the underlying [ic] *)
     | Close
 
   type t = {
@@ -266,7 +277,7 @@ module Reader = struct
   external apply_masking_ :
     key:bytes -> key_offset:int -> buf:bytes -> int -> int -> unit
     = "tiny_httpd_ws_apply_masking"
-    [@@noalloc]
+  [@@noalloc]
   (** Apply masking to the parsed data *)
 
   let[@inline] apply_masking ~mask_key ~mask_offset (buf : bytes) off len : unit
@@ -390,8 +401,8 @@ module Reader = struct
     )
 end
 
-let upgrade ic oc : _ * _ =
-  let writer = Writer.create ~oc () in
+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
@@ -414,9 +425,11 @@ let upgrade ic oc : _ * _ =
   in
   ws_ic, ws_oc
 
-(** Turn a regular connection handler (provided by the user) into a websocket upgrade handler *)
+(** Turn a regular connection handler (provided by the user) into a websocket
+    upgrade handler *)
 module Make_upgrade_handler (X : sig
   val accept_ws_protocol : string -> bool
+  val with_lock : With_lock.builder
   val handler : handler
 end) : Server.UPGRADE_HANDLER with type handshake_state = unit Request.t =
 struct
@@ -461,7 +474,8 @@ struct
     try Ok (handshake_ req) with Bad_req s -> Error s
 
   let handle_connection req ic oc =
-    let ws_ic, ws_oc = upgrade ic oc in
+    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");
@@ -469,9 +483,11 @@ struct
 end
 
 let add_route_handler ?accept ?(accept_ws_protocol = fun _ -> true) ?middlewares
-    (server : Server.t) route (f : handler) : unit =
+    ?(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

src/ws/tiny_httpd_ws.mli

@@ -1,30 +1,60 @@
 (** Websockets for Tiny_httpd.
 
-    This sub-library ([tiny_httpd.ws]) exports a small implementation
-    for a websocket server. It has no additional dependencies.
-    *)
+    This sub-library ([tiny_httpd.ws]) exports a small implementation for a
+    websocket server. It has no additional dependencies. *)
+
+(** 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 : IO.Input.t -> IO.Output.t -> IO.Input.t * IO.Output.t
-(** Upgrade a byte stream to the websocket framing protocol. *)
+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. *)
+(** 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 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. *)
 
 (**/**)
 

src/ws/tiny_httpd_ws_stubs.c

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

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

tests/unit/dune

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

tests/unit/t_response.ml

@@ -0,0 +1,17 @@
+open Test_util
+open Tiny_httpd_core
+module U = Util
+
+let () =
+  let res =
+    Response.make_raw ~code:200 ~headers:[ "content-length", "42" ] ""
+  in
+  let h = Headers.get_exn "content-length" res.headers in
+  assert_eq "42" h
+
+let () =
+  let res =
+    Response.make_raw ~code:200 ~headers:[ "Content-Length", "42" ] ""
+  in
+  let h = Headers.get_exn "content-length" res.headers in
+  assert_eq "42" h

tiny_httpd.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.18"
+version: "0.19"
 synopsis: "Minimal HTTP server using threads"
 maintainer: ["c-cube"]
 authors: ["c-cube"]

tiny_httpd_camlzip.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.18"
+version: "0.19"
 synopsis: "Interface to camlzip for tiny_httpd"
 maintainer: ["c-cube"]
 authors: ["c-cube"]