Better support for deflate

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_string ~compression:`DEFLATE server `OK "Hello World!\n"
-  Vif.Response.with_stream ~compression:`DEFLATE server `OK stream
 ;;
 
 let () = Miou_unix.run @@ fun () ->

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

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 req = H1.Reqd.request reqd in
-      let hdrs = Hdrs.add_unless_exists hdrs "content-length" length in
+      let hdrs = req.H1.Request.headers in
-      let hdrs = Hdrs.add_unless_exists hdrs "connection" "close" in
+      begin
-      let str = compress_string ~headers:hdrs str in
+        match H1.Headers.get hdrs "accept-encoding" with
-      let hdrs = H1.Headers.of_list hdrs in
+        | None -> false
-      let status =
+        | Some str ->
-        match status with
+            let algs = String.split_on_char ',' str in
-        | #H1.Status.t as status -> status
+            let algs = List.map String.trim algs in
-        | status ->
+            List.exists (( = ) alg) algs
-            Log.err (fun m -> m "Invalid status: %a" H2.Status.pp_hum status);
+      end
-            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
   | `V2 reqd ->
-      let length = strf "%d" (String.length str) in
+      let req = H2.Reqd.request reqd in
-      let hdrs = Hdrs.add_unless_exists hdrs "content-length" length in
+      let hdrs = req.H2.Request.headers in
-      let str = compress_string ~headers:hdrs str in
+      begin
-      let hdrs = H2.Headers.of_list hdrs in
+        match H2.Headers.get hdrs "accept-encoding" with
-      let resp = H2.Response.create ~headers:hdrs status in
+        | None -> false
-      H2.Reqd.respond_with_string reqd resp str;
+        | Some str ->
-      Response
+            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 when can_compress "deflate" server ->
-    | Some `DEFLATE ->
         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)