diff --git a/examples/07-deflate/main.ml b/examples/07-deflate/main.ml index a15f346..b89593d 100644 --- a/examples/07-deflate/main.ml +++ b/examples/07-deflate/main.ml @@ -1,8 +1,7 @@ #require "vif" ;; let default req target server () = - let stream = Vif.Stream.Stream.singleton "Hello World!\n" in - Vif.Response.with_stream ~compression:`DEFLATE server `OK stream + Vif.Response.with_string ~compression:`DEFLATE server `OK "Hello World!\n" ;; let () = Miou_unix.run @@ fun () -> diff --git a/lib/vif/vif.mli b/lib/vif/vif.mli index de6471b..e7d3ed6 100644 --- a/lib/vif/vif.mli +++ b/lib/vif/vif.mli @@ -232,7 +232,13 @@ module Response : sig -> string Stream.stream -> t - val with_string : S.t -> ?headers:Headers.t -> Status.t -> string -> t + val with_string : + ?compression:[ `DEFLATE ] + -> S.t + -> ?headers:Headers.t + -> Status.t + -> string + -> t end type config diff --git a/lib/vif/vif_response.ml b/lib/vif/vif_response.ml index 0cffd30..c9dbe4c 100644 --- a/lib/vif/vif_response.ml +++ b/lib/vif/vif_response.ml @@ -13,38 +13,35 @@ let compress_string ~headers str = | Some "gzip" -> assert false | _ -> str -let with_string server ?headers:(hdrs = []) status str = +let can_compress alg server = match Vif_s.reqd server with | `V1 reqd -> - let length = strf "%d" (String.length str) in - let hdrs = Hdrs.add_unless_exists hdrs "content-length" length in - let hdrs = Hdrs.add_unless_exists hdrs "connection" "close" in - let str = compress_string ~headers:hdrs str in - let hdrs = H1.Headers.of_list hdrs in - let status = - match status with - | #H1.Status.t as status -> status - | status -> - Log.err (fun m -> m "Invalid status: %a" H2.Status.pp_hum status); - invalid_arg "Response.with_string: invalid status" - in - let resp = H1.Response.create ~headers:hdrs status in - H1.Reqd.respond_with_string reqd resp str; - Response + let req = H1.Reqd.request reqd in + let hdrs = req.H1.Request.headers in + begin + match H1.Headers.get hdrs "accept-encoding" with + | None -> false + | Some str -> + let algs = String.split_on_char ',' str in + let algs = List.map String.trim algs in + List.exists (( = ) alg) algs + end | `V2 reqd -> - let length = strf "%d" (String.length str) in - let hdrs = Hdrs.add_unless_exists hdrs "content-length" length in - let str = compress_string ~headers:hdrs str in - let hdrs = H2.Headers.of_list hdrs in - let resp = H2.Response.create ~headers:hdrs status in - H2.Reqd.respond_with_string reqd resp str; - Response + let req = H2.Reqd.request reqd in + let hdrs = req.H2.Request.headers in + begin + match H2.Headers.get hdrs "accept-encoding" with + | None -> false + | Some str -> + let algs = String.split_on_char ',' str in + let algs = List.map String.trim algs in + List.exists (( = ) alg) algs + end let with_stream ?compression server ?headers status stream = let headers, stream = match compression with - | None -> (headers, stream) - | Some `DEFLATE -> + | Some `DEFLATE when can_compress "deflate" server -> let headers = match headers with | None -> Some [ ("content-encoding", "deflate") ] @@ -53,7 +50,11 @@ let with_stream ?compression server ?headers status stream = |> Option.some in (headers, Stream.Stream.via (Stream.Flow.deflate ()) stream) + | _ -> (headers, stream) in let sink = Stream.Sink.response ?headers status server in Stream.Stream.into sink stream; Response + +let with_string ?compression server ?headers status str = + with_stream ?compression server ?headers status (Stream.Stream.singleton str)