Merge a56dd0ec65 into 6203e7a4a7

close #92

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

@@ -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.17)
+(version 0.19)
 (source (github c-cube/tiny_httpd))
 (homepage https://github.com/c-cube/tiny_httpd/)
 (license MIT)

examples/echo.ml

@@ -134,6 +134,7 @@ let setup_upload server : unit =
 let () =
   let port_ = ref 8080 in
   let j = ref 32 in
+  let addr = ref "127.0.0.1" in
   Arg.parse
     (Arg.align
        [
@@ -141,11 +142,12 @@ let () =
          "-p", Arg.Set_int port_, " set port";
          "--debug", Arg.Unit setup_logging, " enable debug";
          "-j", Arg.Set_int j, " maximum number of connections";
+        "--addr", Arg.Set_string addr, " binding address";
        ])
     (fun _ -> raise (Arg.Bad ""))
     "echo [option]*";
 
-  let server = Tiny_httpd.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

src/Tiny_httpd.ml

@@ -30,7 +30,8 @@ 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 ?middlewares () : t =
+    ?(addr = "127.0.0.1") ?(port = 8080) ?sock ?head_middlewares ?middlewares ()
+    : t =
   let max_connections = get_max_connection_ ?max_connections () in
   let server =
     {
@@ -65,4 +66,5 @@ let create ?enable_logging ?(masksigpipe = not Sys.win32) ?max_connections
     let tcp_server () = tcp_server_builder
   end in
   let backend = (module B : IO_BACKEND) in
-  Server.create_from ?enable_logging ?buf_size ?middlewares ~backend ()
+  Server.create_from ?enable_logging ?buf_size ?head_middlewares ?middlewares
+    ~backend ()

src/Tiny_httpd.mli

@@ -135,6 +135,7 @@ val create :
   ?addr:string ->
   ?port:int ->
   ?sock:Unix.file_descr ->
+  ?head_middlewares:Head_middleware.t list ->
   ?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
   unit ->
   t
@@ -169,7 +170,7 @@ val create :
       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 NEXT_RELEASE. Does not affect debug-level logs.
+      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/bin/http_of_dir.ml

@@ -1,7 +1,5 @@
 module S = Tiny_httpd
-module U = Tiny_httpd.Util
 module D = Tiny_httpd.Dir
-module Pf = Printf
 module Log = Tiny_httpd.Log
 
 let serve ~config ~timeout (dir : string) addr port j : _ result =
@@ -9,9 +7,9 @@ let serve ~config ~timeout (dir : string) addr port j : _ result =
   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
 
@@ -63,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),

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/log.mli

@@ -14,4 +14,4 @@ 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 NEXT_RELEASE *)
+  @since 0.18 *)

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/response.mli

@@ -126,7 +126,7 @@ val pp_with :
       Default is ["set-cookie"].
     @param pp_body body printer
       (default fully prints String bodies, but omits stream bodies)
-    @since NEXT_RELEASE *)
+    @since 0.18 *)
 
 val pp : Format.formatter -> t -> unit
 (** Pretty print the response. The exact format is not specified. *)

src/core/response_code.ml

@@ -5,6 +5,7 @@ let not_found = 404
 
 let descr = function
   | 100 -> "Continue"
+  | 101 -> "Switching Protocols"
   | 200 -> "OK"
   | 201 -> "Created"
   | 202 -> "Accepted"

src/core/server.ml

@@ -88,6 +88,7 @@ type t = {
   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} *)
@@ -128,6 +129,9 @@ let add_middleware ~stage self m =
   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 =
@@ -258,6 +262,7 @@ let add_route_server_sent_handler ?accept ?(middlewares = []) self route 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 (
@@ -274,7 +279,7 @@ let add_upgrade_handler ?(accept = fun _ -> Ok ()) ?(middlewares = [])
 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)
-    ?(middlewares = []) ~backend () : t =
+    ?(head_middlewares = []) ?(middlewares = []) ~backend () : t =
   let handler _req = Response.fail ~code:404 "no top handler" in
   let self =
     {
@@ -283,6 +288,7 @@ let create_from ?(enable_logging = not Log.dummy) ?(buf_size = 16 * 1_024)
       tcp_server = None;
       handler;
       path_handlers = [];
+      head_middlewares;
       middlewares = [];
       middlewares_sorted = lazy [];
       bytes_pool =

src/core/server.mli

@@ -83,6 +83,7 @@ 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 ->
@@ -94,9 +95,10 @@ val create_from :
     {!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 NEXT_RELEASE).
+      emit logs via Logs (since 0.18).
       Default [true].
 
     @since 0.14
@@ -152,6 +154,12 @@ val add_middleware :
     @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

src/prometheus/tiny_httpd_prometheus.mli

@@ -72,11 +72,6 @@ module Histogram : sig
   val add : t -> float -> unit
 end
 
-(* TODO:
-   module Histogram : sig
-   end
-*)
-
 val http_middleware : Registry.t -> Server.Middleware.t
 (** Middleware to get basic metrics about HTTP requests *)
 

src/ws/dune

@@ -1,3 +1,28 @@
+; 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)
@@ -7,7 +32,7 @@
  (foreign_stubs
   (language c)
   (names tiny_httpd_ws_stubs)
-  (flags :standard -std=c99 -fPIC -O2))
+  (flags :standard (:include cflags.sexp)))
  (libraries
   (re_export tiny_httpd.core)
   threads))

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

tests/upload_chunked.sh

@@ -5,7 +5,7 @@ if [ -f data ]; then rm data ; fi
 SERVER=$1
 PORT=8087
 
-"$SERVER" . -p $PORT --upload --max-upload 100000000000 &
+"$SERVER" . -p $PORT --upload --max-upload 1000M &
 PID=$!
 
 sleep 0.1

tiny_httpd.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.17"
+version: "0.19"
 synopsis: "Minimal HTTP server using threads"
 maintainer: ["c-cube"]
 authors: ["c-cube"]
@@ -11,7 +11,7 @@ tags: [
 homepage: "https://github.com/c-cube/tiny_httpd/"
 bug-reports: "https://github.com/c-cube/tiny_httpd/issues"
 depends: [
-  "dune" {>= "2.9"}
+  "dune" {>= "3.2"}
   "seq"
   "base-threads"
   "result"
@@ -38,11 +38,9 @@ build: [
     name
     "-j"
     jobs
-    "--promote-install-files=false"
     "@install"
     "@runtest" {with-test}
     "@doc" {with-doc}
   ]
-  ["dune" "install" "-p" name "--create-install-files" name]
 ]
 dev-repo: "git+https://github.com/c-cube/tiny_httpd.git"

tiny_httpd_camlzip.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.17"
+version: "0.19"
 synopsis: "Interface to camlzip for tiny_httpd"
 maintainer: ["c-cube"]
 authors: ["c-cube"]
@@ -8,7 +8,7 @@ license: "MIT"
 homepage: "https://github.com/c-cube/tiny_httpd/"
 bug-reports: "https://github.com/c-cube/tiny_httpd/issues"
 depends: [
-  "dune" {>= "2.9"}
+  "dune" {>= "3.2"}
   "tiny_httpd" {= version}
   "camlzip" {>= "1.06"}
   "iostream-camlzip" {>= "0.2.1"}
@@ -24,11 +24,9 @@ build: [
     name
     "-j"
     jobs
-    "--promote-install-files=false"
     "@install"
     "@runtest" {with-test}
     "@doc" {with-doc}
   ]
-  ["dune" "install" "-p" name "--create-install-files" name]
 ]
 dev-repo: "git+https://github.com/c-cube/tiny_httpd.git"