use bigstring and map_file

src/Tiny_httpd.ml

@@ -107,6 +107,7 @@ module Byte_stream = struct
         | None -> Bytes.length s - i
       )
     in
+
     let i = ref i in
     { bs_fill_buf=(fun () -> s, !i, !len);
       bs_close=(fun () -> len := 0);
@@ -116,6 +117,29 @@ module Byte_stream = struct
   let of_string s : t =
     of_bytes (Bytes.unsafe_of_string s)
 
+  let of_big_string ?(buf_size=16 * 1024) ?(i=0) ?len s : t =
+    let len =
+      ref (
+        match len with
+        | Some n ->
+          if n > Bigstring.length s - i then invalid_arg "Byte_stream.of_bytes";
+          n
+        | None -> Bigstring.length s - i
+      )
+    in
+    let buf = Bytes.make buf_size ' ' in
+    let i = ref i in
+    let len_buf = ref 0 in
+    { bs_fill_buf=(fun () ->
+        if !i >= !len_buf then (
+          i := 0; len_buf := min buf_size !len;
+          Bigstring.blit_to_bytes s !i buf 0 !len_buf;
+        );
+      buf, !i,!len_buf - !i);
+      bs_consume=(fun n -> i := !i + n; len := !len - n);
+      bs_close=(fun () -> len_buf := 0)
+    }
+
   let with_file ?buf_size file f =
     let ic = open_in file in
     try
@@ -591,7 +615,9 @@ end
 *)
 
 module Response = struct
-  type body = [`String of string | `Stream of byte_stream | `Void]
+  type body =
+    | String of string | BigString of Bigstring.t
+    | Stream of byte_stream | Void
   type t = {
     code: Response_code.t;
     headers: Headers.t;
@@ -609,15 +635,22 @@ module Response = struct
     let headers =
       Headers.set "Content-Length" (string_of_int (String.length body)) headers
     in
-    { code; headers; body=`String body; }
+    { code; headers; body=String body; }
+
+  let make_raw_big ?(headers=[]) ~code body : t =
+    (* add content length to response *)
+    let headers =
+      Headers.set "Content-Length" (string_of_int (Bigstring.length body)) headers
+    in
+    { code; headers; body=BigString body; }
 
   let make_raw_stream ?(headers=[]) ~code body : t =
     (* add content length to response *)
     let headers = Headers.set "Transfer-Encoding" "chunked" headers in
-    { code; headers; body=`Stream body; }
+    { code; headers; body=Stream body; }
 
   let make_void ?(headers=[]) ~code () : t =
-    { code; headers; body=`Void; }
+    { code; headers; body=Void; }
 
   let make_string ?headers r = match r with
     | Ok body -> make_raw ?headers ~code:200 body
@@ -628,9 +661,10 @@ module Response = struct
     | Error (code,msg) -> make_raw ?headers ~code msg
 
   let make ?headers r : t = match r with
-    | Ok (`String body) -> make_raw ?headers ~code:200 body
+    | Ok (String body) -> make_raw ?headers ~code:200 body
-    | Ok (`Stream body) -> make_raw_stream ?headers ~code:200 body
+    | Ok (BigString body) -> make_raw_big ?headers ~code:200 body
-    | Ok `Void -> make_void ?headers ~code:200 ()
+    | Ok (Stream body) -> make_raw_stream ?headers ~code:200 body
+    | Ok Void -> make_void ?headers ~code:200 ()
     | Error (code,msg) -> make_raw ?headers ~code msg
 
   let fail ?headers ~code fmt =
@@ -640,9 +674,10 @@ module Response = struct
 
   let pp out self : unit =
     let pp_body out = function
-      | `String s -> Format.fprintf out "%S" s
+      | String s -> Format.fprintf out "%S" s
-      | `Stream _ -> Format.pp_print_string out "<stream>"
+      | BigString _ -> Format.pp_print_string out "<bigstring>"
-      | `Void -> ()
+      | Stream _ -> Format.pp_print_string out "<stream>"
+      | Void -> ()
     in
     Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}"
       self.code Headers.pp self.headers pp_body self.body
@@ -666,12 +701,16 @@ module Response = struct
   let output_ (oc:out_channel) (self:t) : unit =
     Printf.fprintf oc "HTTP/1.1 %d %s\r\n" self.code (Response_code.descr self.code);
     let body, is_chunked = match self.body with
-      | `String s when String.length s > 1024 * 500 ->
+      | String s when String.length s > 1024 * 500 ->
         (* chunk-encode large bodies *)
-        `Stream (Byte_stream.of_string s), true
+        Stream (Byte_stream.of_string s), true
-      | `String _ as b -> b, false
+      | BigString s when Bigstring.length s > 1024 * 500 ->
-      | `Stream _ as b -> b, true
+        (* chunk-encode large bodies *)
-      | `Void as b -> b, false
+        Stream (Byte_stream.of_big_string s), true
+      | String _ as b -> b, false
+      | BigString _ as b -> b, false
+      | Stream _ as b -> b, true
+      | Void as b -> b, false
     in
     let headers =
       if is_chunked then (
@@ -682,13 +721,15 @@ module Response = struct
     in
     let self = {self with headers; body} in
     _debug (fun k->k "output response: %s"
-               (Format.asprintf "%a" pp {self with body=`String "<…>"}));
+               (Format.asprintf "%a" pp {self with body=String "<…>"}));
     List.iter (fun (k,v) -> Printf.fprintf oc "%s: %s\r\n" k v) headers;
     output_string oc "\r\n";
     begin match body with
-      | `String "" | `Void -> ()
+      | String "" | Void -> ()
-      | `String s -> output_string oc s;
+      | String s -> output_string oc s;
-      | `Stream str -> output_stream_chunked_ oc str;
+      | BigString s -> Format.fprintf (Format.formatter_of_out_channel oc)
+                         "%a%!" Bigstring.print s
+      | Stream str -> output_stream_chunked_ oc str;
     end;
     flush oc
 end

src/Tiny_httpd.mli

@@ -141,6 +141,9 @@ module Byte_stream : sig
 
   val of_string : string -> t
 
+  val of_big_string : ?buf_size:int -> ?i:int -> ?len:int -> Bigstring.t -> t
+  (** Make a buffered stream from the given big string. *)
+
   val iter : (bytes -> int -> int -> unit) -> t -> unit
   (** Iterate on the chunks of the stream
       @since 0.3 *)
@@ -331,7 +334,9 @@ end
     the client to answer a {!Request.t}*)
 
 module Response : sig
-  type body = [`String of string | `Stream of byte_stream | `Void]
+  type body =
+    | String of string | BigString of Bigstring.t
+    | Stream of byte_stream | Void
   (** Body of a response, either as a simple string,
       or a stream of bytes, or nothing (for server-sent events). *)
 
@@ -370,6 +375,14 @@ module Response : sig
   (** Make a response from its raw components, with a string body.
       Use [""] to not send a body at all. *)
 
+  val make_raw_big :
+    ?headers:Headers.t ->
+    code:Response_code.t ->
+    Bigstring.t ->
+    t
+  (** Make a response from its raw components, with a big string body.
+      Use [""] to not send a body at all. *)
+
   val make_raw_stream :
     ?headers:Headers.t ->
     code:Response_code.t ->

src/Tiny_httpd_dir.ml

@@ -7,7 +7,6 @@ type dir_behavior =
 
 type config = {
   mutable download: bool;
-  mutable mem_cache: bool;
   mutable dir_behavior: dir_behavior;
   mutable delete: bool;
   mutable upload: bool;
@@ -16,7 +15,6 @@ type config = {
 
 let default_config () : config =
   { download=true
-  ; mem_cache=false
   ; dir_behavior=Forbidden
   ; delete=false
   ; upload=false
@@ -43,7 +41,7 @@ let header_html = "Content-Type", "text/html"
 let (//) = Filename.concat
 
 let encode_path s = U.percent_encode ~skip:(function '/' -> true|_->false) s
-let decode_path s = match U.percent_decode s with Some s->s | None -> s
+let _decode_path s = match U.percent_decode s with Some s->s | None -> s
 
 let is_hidden s = String.length s>0 && s.[0] = '.'
 
@@ -164,30 +162,24 @@ let add_dir_path ~config ~dir ~prefix server =
            (fun _ _  -> S.Response.make_raw ~code:405 "upload not allowed");
   );
 
-  let cache = Hashtbl.create 101 in
-
   if config.download then (
     S.add_route_handler server ~meth:`GET
       S.Route.(exact_path prefix (rest_of_path_urlencoded))
       (fun path req ->
         let full_path = dir // path in
-        let mtime = lazy (
+        let stat =
-                        try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime
+          try Unix.stat full_path
           with _ -> S.Response.fail_raise ~code:403 "Cannot access file"
-                      ) in
+        in
-        try
+        let mtime = stat.Unix.st_mtime in
-          if not config.mem_cache then raise Not_found;
+        let mtime_str = Printf.sprintf "mtime: %f" mtime in
-          let (ans, mtime0) = Hashtbl.find cache path in
-          if mtime <> mtime0 then raise Not_found;
-          ans
-        with Not_found ->
-        let ans =
         if contains_dot_dot full_path then (
           S.Response.fail ~code:403 "Path is forbidden";
         ) else if not (Sys.file_exists full_path) then (
           S.Response.fail ~code:404 "File not found";
-        ) else if S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime) then (
+        ) else
-          S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime));
+          if S.Request.get_header req "If-None-Match" = Some mtime_str then (
+          S._debug (fun k->k "cached object %S (etag: %S)" path mtime_str);
           S.Response.make_raw ~code:304 ""
         ) else if Sys.is_directory full_path then (
           S._debug (fun k->k "list dir %S (topdir %S)"  full_path dir);
@@ -206,13 +198,15 @@ let add_dir_path ~config ~dir ~prefix server =
           | Lists ->
              let body = html_list_dir ~top:dir path ~parent in
              S.Response.make_string
-               ~headers:[header_html; "ETag", Lazy.force mtime]
+               ~headers:[header_html; "ETag", mtime_str]
                (Ok body)
           | Forbidden ->
              S.Response.make_raw ~code:405 "listing dir not allowed"
         ) else (
           try
-            let ic = open_in full_path in
+            let bs = Bigstring_unix.with_map_file ~flags:[Open_rdonly] full_path
+                       (fun s -> s)
+            in
             let mime_type =
               if Filename.extension full_path = ".css" then (
                 ["Content-Type", "text/css"]
@@ -226,14 +220,11 @@ let add_dir_path ~config ~dir ~prefix server =
                         with _ -> [])
                   with _ -> []
             in
-            S.Response.make_raw_stream
+            S.Response.make_raw_big
-              ~headers:(mime_type@["Etag", Lazy.force mtime])
+              ~headers:(mime_type@["Etag", mtime_str])
-              ~code:200 (S.Byte_stream.of_chan ic)
+              ~code:200 bs
           with e ->
             S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e))
-        in
-        Hashtbl.replace cache path (ans,mtime);
-        ans
       )
   ) else (
     S.add_route_handler server ~meth:`GET

src/Tiny_httpd_dir.mli

@@ -4,7 +4,6 @@ type dir_behavior =
 
 type config = {
   mutable download: bool;
-  mutable mem_cache: bool;
   mutable dir_behavior: dir_behavior;
   mutable delete: bool;
   mutable upload: bool;

src/camlzip/Tiny_httpd_camlzip.ml

@@ -178,7 +178,7 @@ let compress_resp_stream_
 
   if accept_deflate req then (
     match resp.body with
-    | `String s when String.length s > compress_above ->
+    | String s when String.length s > compress_above ->
       (* big string, we compress *)
       S._debug
         (fun k->k "encode str response with deflate (size %d, threshold %d)"
@@ -188,15 +188,27 @@ let compress_resp_stream_
       in
       resp
       |> S.Response.update_headers update_headers
-      |> S.Response.set_body (`Stream body)
+      |> S.Response.set_body (Stream body)
 
-    | `Stream str ->
+    | BigString s when Bigstring.length s > compress_above ->
+      (* big string, we compress *)
+      S._debug
+        (fun k->k "encode str response with deflate (size %d, threshold %d)"
+             (Bigstring.length s) compress_above);
+      let body =
+        encode_deflate_stream_ ~buf_size @@ S.Byte_stream.of_big_string s
+      in
+      resp
+      |> S.Response.update_headers update_headers
+      |> S.Response.set_body (Stream body)
+
+    | Stream str ->
       S._debug (fun k->k "encode stream response with deflate");
       resp
       |> S.Response.update_headers update_headers
-      |> S.Response.set_body (`Stream (encode_deflate_stream_ ~buf_size str))
+      |> S.Response.set_body (Stream (encode_deflate_stream_ ~buf_size str))
 
-    | `String _ | `Void -> resp
+    | String _ | BigString _ | Void -> resp
   ) else resp
 
 let middleware
@@ -215,4 +227,3 @@ let setup
   let m = middleware ?compress_above ?buf_size () in
   S._debug (fun k->k "setup gzip support");
   S.add_middleware ~stage:`Encoding server m
-

src/dune

@@ -2,6 +2,6 @@
 (library
   (name tiny_httpd)
   (public_name tiny_httpd)
-  (libraries threads)
+  (libraries threads bigstring bigstring-unix)
   (flags :standard -safe-string -warn-error -a+8)
   (wrapped false))

tests/download_chunked.sh

@@ -7,6 +7,15 @@ PID=$!
 
 sleep 0.1
 
+echo download1 1>&2
+curl -N "http://localhost:${PORT}/foo_50" -o data2 \
+  -H 'Tranfer-encoding: chunked'
+
+echo download2 1>&2
+curl -N "http://localhost:${PORT}/foo_50" -o data2 \
+  -H 'Tranfer-encoding: chunked'
+
+echo download3 1>&2
 curl -N "http://localhost:${PORT}/foo_50" -o data2 \
   -H 'Tranfer-encoding: chunked'