Skip to content

do not compress gzip'd bodies; helpers to return compressed bodies #69

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
c-cube wants to merge 1 commit into
base: master
Choose a base branch
from
Open

do not compress gzip'd bodies; helpers to return compressed bodies #69

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
51 changes: 38 additions & 13 deletions httpev.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -425,15 +425,27 @@ let make_request_headers ~version code hdrs =
put "";
Buffer.contents b

open struct
let has_header_value name value hdrs =
List.exists (fun (k,v) -> Stre.iequal k name && Stre.iequal (String.strip v) value) hdrs

let is_application_gzip hdrs =
List.exists begin fun (k,v) ->
Stre.iequal k "content-type" && Stre.iequal (String.strip @@ Stre.before v ";") "application/gzip"
end hdrs
Comment on lines +429 to +435

@rr0gi rr0gi Sep 22, 2026

Copy link
Copy Markdown
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

there is find_header helper, lets use that


(* compress large bodies, if not already compressed *)
let maybe_gzip encoding hdrs body =
match encoding with
| Gzip when String.length body > 128 &&
not (has_header_value "content-encoding" "gzip" hdrs || is_application_gzip hdrs) ->
("Content-Encoding", "gzip") :: hdrs, Gzip_io.string body
| _ -> hdrs, body
end

let send_reply_async c encoding (code,hdrs,body) =
try
(* possibly apply encoding *)
let (hdrs,body) =
(* TODO do not apply encoding to application/gzip *)
match encoding with
| Gzip when String.length body > 128 -> ("Content-Encoding", "gzip") :: hdrs, Gzip_io.string body
| _ -> hdrs, body
in
let (hdrs,body) = maybe_gzip encoding hdrs body in
let hdrs = ("Content-Length", string_of_int (String.length body)) :: hdrs in
(* do not transfer body for HEAD requests *)
let body = match c.req with Ready { meth = `HEAD; _ } -> "" | _ -> body in
Expand Down Expand Up @@ -479,12 +491,12 @@ let send_reply_user c req (code,hdrs,body) =
let hdrs = maybe_allow_cors c hdrs in
let blocking = Option.is_some req.blocking in
(* filter headers *)
let hdrs = hdrs |> List.filter begin fun (k,_) ->
let hdrs = hdrs |> List.filter begin fun (k,v) ->
let open Stre in
let forbidden =
(iequal k "content-length" && not blocking) || (* httpev will calculate *)
(iequal k "connection") ||
(iequal k "content-encoding") (* none of the user's business *)
(iequal k "content-encoding" && not (iequal (String.strip v) "gzip")) (* none of the user's business *)
in
not forbidden
end in
Expand Down Expand Up @@ -847,6 +859,12 @@ let serve_gzip_io req ?status f =
let serve_text req ?status text =
serve req ?status "text/plain" text

(** Return a body that's already gzip-encoded, add corresponding content-encoding *)
let serve_encoded_gzip req ?status ?(extra=[]) ctype data =
match req.encoding with
| Gzip -> serve req ?status ~extra:(("Content-Encoding", "gzip") :: extra) ctype data
| Identity -> Exn.fail "client does not accept gzip encoding"

let run ?(ip=Unix.inet_addr_loopback) port answer =
server { default with connection = ADDR_INET (ip, port) } answer

Expand Down Expand Up @@ -955,23 +973,24 @@ let send_reply c cout reply =
| _ -> () (* this can happen when sending back error reply on malformed HTTP input *)
end;
(* filter headers *)
let hdrs = hdrs |> List.filter begin fun (k,_) ->
let hdrs = hdrs |> List.filter begin fun (k,v) ->
let open Stre in
let forbidden =
(iequal k "content-length") || (* httpev will calculate *)
(iequal k "connection") ||
(iequal k "transfer-encoding") ||
(iequal k "content-encoding") (* none of the user's business *)
(iequal k "content-encoding" && not (iequal (String.strip v) "gzip")) (* none of the user's business *)
in
not forbidden
end
in
(* possibly apply encoding *)
let (hdrs,body) =
(* TODO do not apply encoding to application/gzip *)

@rr0gi rr0gi Sep 22, 2026

Copy link
Copy Markdown
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

👍 :)

(* TODO gzip + chunked? *)
match body, code, c.req with
| `Body s, `Ok, Ready { encoding=Gzip; _ } when String.length s > 128 -> ("Content-Encoding", "gzip")::hdrs, `Body (Gzip_io.string s)
| `Body s, `Ok, Ready { encoding; _ } ->
let hdrs, s = maybe_gzip encoding hdrs s in
hdrs, `Body s
| _ -> hdrs, body
in
let hdrs = match body with
Expand Down Expand Up @@ -1179,6 +1198,12 @@ let printf ?status ?extra fmt = ksprintf (fun s -> text ?status ?extra s) fmt
let json = return ~typ:"application/json"
let yojson ?status ?extra x = json ?status ?extra (Yojson.Safe.to_string x)

(** Return a body that's already gzip-encoded, add corresponding content-encoding *)
let encoded_gzip req ?status ?(extra=[]) ~typ data =
match req.encoding with
| Gzip -> return ?status ~extra:(("Content-Encoding", "gzip") :: extra) ~typ data
| Identity -> Exn.fail "client does not accept gzip encoding"

let error status s = text ~status s
let not_found = error `Not_found
let bad_request = error `Bad_request
Expand Down
Loading