wip: zlib bridge library

src/Tiny_httpd.ml

@@ -28,6 +28,7 @@ module Buf_ = struct
     { bytes=Bytes.make size ' '; i=0 }
 
   let size self = self.i
+  let bytes_slice self = self.bytes
   let clear self : unit =
     if Bytes.length self.bytes > 4_096 * 1_024 then (
       self.bytes <- Bytes.make 4096 ' '; (* free big buffer *)

src/Tiny_httpd.mli

@@ -79,6 +79,18 @@ module Buf_ : sig
   val clear : t -> unit
   val create : ?size:int -> unit -> t
   val contents : t -> string
+
+  val bytes_slice : t -> bytes
+  (** Access underlying slice of bytes.
+      @since NEXT_RELEASE *)
+
+  val contents_and_clear : t -> string
+  (** Get contents of the buffer and clear it.
+      @since NEXT_RELEASE *)
+
+  val add_bytes : t -> bytes -> int -> int -> unit
+  (** Append given bytes slice to the buffer.
+      @since NEXT_RELEASE *)
 end
 
 (** {2 Generic stream of data}

src/examples/dune

@@ -1,4 +1,4 @@
 
 (executables
   (names echo)
-  (libraries tiny_httpd))
+  (libraries tiny_httpd tiny_httpd_zlib))

src/examples/echo.ml

@@ -11,6 +11,7 @@ let () =
       "-j", Arg.Set_int j, " maximum number of connections";
     ]) (fun _ -> raise (Arg.Bad "")) "echo [option]*";
   let server = S.create ~port:!port_ ~max_connections:!j () in
+  Tiny_httpd_zlib.setup server;
   (* say hello *)
   S.add_path_handler ~meth:`GET server
     "/hello/%s@/" (fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n")));

src/zlib/Tiny_httpd_zlib.ml

@@ -0,0 +1,80 @@
+
+module S = Tiny_httpd
+module BS = Tiny_httpd.Byte_stream
+
+let mk_decode_deflate_stream_ () (is:S.byte_stream) : S.byte_stream =
+  S._debug (fun k->k "wrap stream with inflate.decode");
+  let buf = Bytes.make 4096 ' ' in
+  let write_offset = ref 0 in
+  let buf_len = ref 0 in
+  let zlib_str = Zlib.inflate_init false in
+  let is_done = ref false in
+  let bs_close () =
+    Zlib.inflate_end zlib_str;
+    BS.close is
+  in
+  let bs_consume len : unit =
+    if len > !buf_len then (
+      S.Response.fail_raise ~code:400
+        "inflate: error during decompression: invalid consume len %d (max %d)"
+        len !buf_len
+    );
+    write_offset := !write_offset + len;
+    buf_len := !buf_len - len;
+  in
+  let bs_fill_buf () : _*_*_ =
+    (* refill [buf] if needed *)
+    if !buf_len = 0 && not !is_done then (
+      let ib, ioff, ilen = is.S.bs_fill_buf () in
+      begin
+        try
+          let finished, used_in, used_out =
+            Zlib.inflate zlib_str
+              buf 0 (Bytes.length buf)
+              ib ioff ilen Zlib.Z_SYNC_FLUSH
+          in
+          is.S.bs_consume used_in;
+          write_offset := 0;
+          buf_len := used_out;
+          if finished then is_done := true;
+          S._debug (fun k->k "decode %d bytes as %d bytes from inflate (finished: %b)"
+                       used_in used_out finished);
+        with Zlib.Error (e1,e2) ->
+          S.Response.fail_raise ~code:400
+            "inflate: error during decompression:\n%s %s" e1 e2
+      end;
+      S._debug (fun k->k "inflate: refill %d bytes into internal buf" !buf_len);
+    );
+    buf, !write_offset, !buf_len
+  in
+  {S.bs_fill_buf; bs_consume; bs_close}
+
+let has_deflate s =
+  try Scanf.sscanf s "deflate; %s" (fun _ -> true)
+  with _ -> false
+
+let cb_decode_compressed_stream (req:unit S.Request.t) : _ option =
+  match S.Request.get_header ~f:String.trim req "Transfer-Encoding" with
+  (* TODO
+    | Some "gzip" ->
+      let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in
+      Some (req', decode_gzip_stream_)
+  *)
+  | Some "deflate" ->
+    let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in
+    Some (req', mk_decode_deflate_stream_ ())
+  | Some s when has_deflate s ->
+    begin match Scanf.sscanf s "deflate; %s" (fun s -> s) with
+      | tr' ->
+        let req' = S.Request.set_header req "Transfer-Encoding" tr' in
+        Some (req', mk_decode_deflate_stream_ ())
+      | exception _ -> None
+    end
+  | _ -> None
+
+let setup (server:S.t) : unit =
+  S._debug (fun k->k "setup gzip support");
+  S.add_decode_request_cb server cb_decode_compressed_stream;
+  (*   S.add_encode_response_cb server (assert false); *)
+  ()
+

src/zlib/Tiny_httpd_zlib.mli

@@ -0,0 +1,3 @@
+
+val setup : Tiny_httpd.t -> unit
+(** Install callbacks for tiny_httpd to be able to encode/decode compressed streams *)

src/zlib/dune

@@ -0,0 +1,7 @@
+
+(library
+  (name tiny_httpd_zlib)
+  (public_name tiny_httpd_zlib)
+  (synopsis "A wrapper around zlib to bring compression to Tiny_httpd")
+  (flags :standard -safe-string -warn-error -a)
+  (libraries tiny_httpd camlzip))

tiny_httpd_zlib.opam

@@ -0,0 +1,23 @@
+opam-version: "2.0"
+version: "0.1"
+authors: ["Simon Cruanes"]
+maintainer: "simon.cruanes.2007@m4x.org"
+license: "MIT"
+description: "Interface to gzip for tiny_httpd"
+build: [
+  ["dune" "build" "@install" "-p" name "-j" jobs]
+  ["dune" "build" "@doc" "-p" name] {with-doc}
+  ["dune" "runtest" "-p" name] {with-test}
+]
+depends: [
+  "dune" { >= "1.1" }
+  "decompress"
+  "tiny_httpd" { = version }
+  "ocaml" { >= "4.03.0" }
+  "odoc" {with-doc}
+]
+tags: [ "http" "thread" "server" "gzip" "decompress" ]
+homepage: "https://github.com/c-cube/tiny_httpd/"
+doc: "https://c-cube.github.io/tiny_httpd/"
+bug-reports: "https://github.com/c-cube/tiny_httpd/issues"
+dev-repo: "git+https://github.com/c-cube/tiny_httpd.git"