From 613c9ae7c35ac46f4ab84ad7a4ac4fcb627811bb Mon Sep 17 00:00:00 2001 From: craff Date: Fri, 17 Dec 2021 18:55:06 -1000 Subject: [PATCH 01/14] Add a module to server static files --- src/Tiny_httpd.ml | 7 +- src/Tiny_httpd.mli | 4 + src/Tiny_httpd_dir.ml | 229 +++++++++++++++++++++++++++++++++++++++ src/Tiny_httpd_dir.mli | 19 ++++ src/bin/http_of_dir.ml | 240 ++++------------------------------------- 5 files changed, 276 insertions(+), 223 deletions(-) create mode 100644 src/Tiny_httpd_dir.ml create mode 100644 src/Tiny_httpd_dir.mli diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index 89a76c0c..ae836b62 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -749,7 +749,12 @@ module Route = struct let string_urlencoded = String_urlencoded let int = Int let exact (s:string) = Exact s - + let exact_path (s:string) tail = + let rec fn = function + | [] -> tail + | s::ls -> exact s @/ fn ls + in + fn (String.split_on_char '/' s) let rec eval : type a b. path -> (a,b) t -> a -> b option = fun path route f -> diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index 6f713b9c..539f440c 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -454,6 +454,10 @@ module Route : sig (** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"], and [route] matches ["bar/…"]. *) + val exact_path : string -> ('a,'b) t -> ('a,'b) t + (** [exact_path "foo/bar/..." r] is equivalent to + [exact "foo" @/ exact "bar" @/ ... @/ r] **) + val pp : Format.formatter -> _ t -> unit (** Print the route. @since 0.7 *) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml new file mode 100644 index 00000000..d5e1731c --- /dev/null +++ b/src/Tiny_httpd_dir.ml @@ -0,0 +1,229 @@ +module S = Tiny_httpd +module U = Tiny_httpd_util +module Pf = Printf + +type dir_behavior = + Index | Forbidden | Lists + +type config = { + mutable download: bool; + mutable mem_cache: bool; + mutable dir_behavior: dir_behavior; + mutable delete: bool; + mutable upload: bool; + mutable max_upload_size: int; +} + +let default_config () : config = + { download=true + ; mem_cache=false + ; dir_behavior=Forbidden + ; delete=false + ; upload=false + ; max_upload_size = 10 * 1024 * 1024 + } + +let contains_dot_dot s = + try + String.iteri + (fun i c -> + if c='.' && i+1 < String.length s && String.get s (i+1) = '.' then raise Exit) + s; + false + with Exit -> true + +(* Human readable size *) +let human_size (x:int) : string = + if x >= 1_000_000_000 then Printf.sprintf "%d.%dG" (x / 1_000_000_000) ((x/1_000_000) mod 1_000_000) + else if x >= 1_000_000 then Printf.sprintf "%d.%dM" (x / 1_000_000) ((x/1000) mod 1_000) + else if x >= 1_000 then Printf.sprintf "%d.%dk" (x/1000) ((x/100) mod 10) + else Printf.sprintf "%db" x + +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 is_hidden s = String.length s>0 && s.[0] = '.' + +let html_list_dir ~top ~parent d : string = + let entries = Sys.readdir @@ (top // d) in + Array.sort compare entries; + let body = Buffer.create 256 in + (* TODO: breadcrumbs for the path, each element a link to the given ancestor dir *) + Printf.bprintf body {| http_of_dir %S + +

Index of %S

+ |} top d; + begin match parent with + | None -> () + | Some p -> + Printf.bprintf body " (parent directory) \n" + (encode_path p); + end; + Printf.bprintf body "\n"; + Buffer.contents body + +let finally_ ~h x f = + try + let y = f x in + h x; + y + with e -> + h x; + raise e + +(* TODO +let wdays = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|] +let date_of_time (f:float) : string = + let open Unix in + let t = Unix.gmtime f in + Printf.sprintf "%s, %02d %d %d %d:%d:%d GMT" + wdays.(t.tm_yday) t.tm_mday t.tm_mon t.tm_year t.tm_hour t.tm_min t.tm_sec + *) + +let add_dir_path ~config ~dir ~prefix server = + + if config.delete then ( + S.add_route_handler server ~meth:`DELETE + S.Route.(exact_path prefix (rest_of_path_urlencoded)) + (fun path _req -> + if contains_dot_dot path then ( + S.Response.fail_raise ~code:403 "invalid path in delete" + ) else ( + S.Response.make_string + (try + Sys.remove (dir // path); Ok "file deleted successfully" + with e -> Error (500, Printexc.to_string e)) + ) + ); + ) else ( + S.add_route_handler server ~meth:`DELETE + S.Route.(exact_path prefix (S.Route.(string @/ return))) + (fun _ _ -> S.Response.make_raw ~code:405 "delete not allowed"); + ); + + if config.upload then ( + S.add_route_handler_stream server ~meth:`PUT + S.Route.(exact_path prefix (rest_of_path_urlencoded)) + ~accept:(fun req -> + match S.Request.get_header_int req "Content-Length" with + | Some n when n > config.max_upload_size -> + Error (403, "max upload size is " ^ string_of_int config.max_upload_size) + | Some _ when contains_dot_dot req.S.Request.path -> + Error (403, "invalid path (contains '..')") + | _ -> Ok () + ) + (fun path req -> + let fpath = dir // path in + let oc = + try open_out fpath + with e -> + S.Response.fail_raise ~code:403 "cannot upload to %S: %s" + path (Printexc.to_string e) + in + let req = S.Request.limit_body_size ~max_size:config.max_upload_size req in + S.Byte_stream.to_chan oc req.S.Request.body; + flush oc; + close_out oc; + S._debug (fun k->k "done uploading"); + S.Response.make_raw ~code:201 "upload successful" + ) + ) else ( + S.add_route_handler server ~meth:`PUT + S.Route.(exact_path prefix (string @/ return)) + (fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed"); + ); + + 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 ( + try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime + with _ -> S.Response.fail_raise ~code:403 "Cannot access file" + ) in + 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 ( + S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime)); + 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); + let parent = Filename.(dirname path) in + let parent = if parent <> path then Some parent else None in + match config.dir_behavior with + | Index -> + if Sys.file_exists (full_path // "index.html") then ( + (* redirect using path, not full path *) + let new_path = "/" // path // "index.html" in + S._debug (fun k->k "redirect to `%s`" new_path); + S.Response.make_raw ~code:301 "" + ~headers:S.Headers.(empty |> set "location" new_path)) + else + S.Response.fail_raise ~code:403 "Cannot access file" + | Lists -> + let body = html_list_dir ~top:dir path ~parent in + S.Response.make_string + ~headers:[header_html; "ETag", Lazy.force mtime] + (Ok body) + | Forbidden -> + S.Response.make_raw ~code:405 "listing dir not allowed" + ) else ( + try + let ic = open_in full_path in + let mime_type = + if Filename.extension full_path = ".css" then ( + ["Content-Type", "text/css"] + ) else if Filename.extension full_path = ".js" then ( + ["Content-Type", "text/javascript"] + ) else try + let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" full_path) in + finally_ ~h:(fun p->ignore @@ Unix.close_process_in p) p + (fun p -> + try ["Content-Type", String.trim (input_line p)] + with _ -> []) + with _ -> [] + in + S.Response.make_raw_stream + ~headers:(mime_type@["Etag", Lazy.force mtime]) + ~code:200 (S.Byte_stream.of_chan ic) + with e -> + S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e))) + ) else ( + S.add_route_handler server ~meth:`GET + S.Route.(exact_path prefix (string @/ return)) + (fun _ _ -> S.Response.make_raw ~code:405 "download not allowed"); + ); diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli new file mode 100644 index 00000000..57e6dcb2 --- /dev/null +++ b/src/Tiny_httpd_dir.mli @@ -0,0 +1,19 @@ + +type dir_behavior = + Index | Forbidden | Lists + +type config = { + mutable download: bool; + mutable mem_cache: bool; + mutable dir_behavior: dir_behavior; + mutable delete: bool; + mutable upload: bool; + mutable max_upload_size: int; +} + +val default_config : unit -> config + +val add_dir_path : config:config -> + dir:string -> + prefix:string -> + Tiny_httpd.t -> unit diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index b695b3bf..252cfd10 100644 --- a/src/bin/http_of_dir.ml +++ b/src/bin/http_of_dir.ml @@ -1,221 +1,14 @@ module S = Tiny_httpd module U = Tiny_httpd_util +module D = Tiny_httpd_dir module Pf = Printf -type config = { - mutable addr: string; - mutable port: int; - mutable upload: bool; - mutable max_upload_size: int; - mutable auto_index_html: bool; - mutable delete: bool; - mutable j: int; -} - -let default_config () : config = { - addr="127.0.0.1"; - port=8080; - delete=false; - upload=false; - max_upload_size = 10 * 1024 * 1024; - auto_index_html=true; - j=32; -} - -let contains_dot_dot s = - try - String.iteri - (fun i c -> - if c='.' && i+1 < String.length s && String.get s (i+1) = '.' then raise Exit) - s; - false - with Exit -> true - -(* Human readable size *) -let human_size (x:int) : string = - if x >= 1_000_000_000 then Printf.sprintf "%d.%dG" (x / 1_000_000_000) ((x/1_000_000) mod 1_000_000) - else if x >= 1_000_000 then Printf.sprintf "%d.%dM" (x / 1_000_000) ((x/1000) mod 1_000) - else if x >= 1_000 then Printf.sprintf "%d.%dk" (x/1000) ((x/100) mod 10) - else Printf.sprintf "%db" x - -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 is_hidden s = String.length s>0 && s.[0] = '.' - -let html_list_dir ~top ~parent d : string = - let entries = Sys.readdir @@ (top // d) in - Array.sort compare entries; - let body = Buffer.create 256 in - (* TODO: breadcrumbs for the path, each element a link to the given ancestor dir *) - Printf.bprintf body {| http_of_dir %S - -

Index of %S

- |} top d; - begin match parent with - | None -> () - | Some p -> - Printf.bprintf body " (parent directory) \n" - (encode_path p); - end; - Printf.bprintf body "\n"; - Buffer.contents body - -let finally_ ~h x f = - try - let y = f x in - h x; - y - with e -> - h x; - raise e - -(* TODO -let wdays = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|] -let date_of_time (f:float) : string = - let open Unix in - let t = Unix.gmtime f in - Printf.sprintf "%s, %02d %d %d %d:%d:%d GMT" - wdays.(t.tm_yday) t.tm_mday t.tm_mon t.tm_year t.tm_hour t.tm_min t.tm_sec - *) - -let serve ~config (dir:string) : _ result = - let server = S.create ~max_connections:config.j ~addr:config.addr ~port:config.port () in +let serve ~config (dir:string) addr port j : _ result = + let server = S.create ~max_connections:j ~addr ~port () in Printf.printf "serve directory %s on http://%(%s%):%d\n%!" - dir (if S.is_ipv6 server then "[%s]" else "%s") config.addr config.port; - if config.delete then ( - S.add_route_handler server ~meth:`DELETE - S.Route.rest_of_path_urlencoded - (fun path _req -> - if contains_dot_dot path then ( - S.Response.fail_raise ~code:403 "invalid path in delete" - ) else ( - S.Response.make_string - (try - Sys.remove (dir // path); Ok "file deleted successfully" - with e -> Error (500, Printexc.to_string e)) - ) - ); - ) else ( - S.add_route_handler server ~meth:`DELETE - S.Route.(string @/ return) - (fun _ _ -> S.Response.make_raw ~code:405 "delete not allowed"); - ); - if config.upload then ( - S.add_route_handler_stream server ~meth:`PUT - S.Route.rest_of_path_urlencoded - ~accept:(fun req -> - match S.Request.get_header_int req "Content-Length" with - | Some n when n > config.max_upload_size -> - Error (403, "max upload size is " ^ string_of_int config.max_upload_size) - | Some _ when contains_dot_dot req.S.Request.path -> - Error (403, "invalid path (contains '..')") - | _ -> Ok () - ) - (fun path req -> - let fpath = dir // path in - let oc = - try open_out fpath - with e -> - S.Response.fail_raise ~code:403 "cannot upload to %S: %s" - path (Printexc.to_string e) - in - let req = S.Request.limit_body_size ~max_size:config.max_upload_size req in - S.Byte_stream.to_chan oc req.S.Request.body; - flush oc; - close_out oc; - S._debug (fun k->k "done uploading"); - S.Response.make_raw ~code:201 "upload successful" - ) - ) else ( - S.add_route_handler server ~meth:`PUT - S.Route.(string @/ return) - (fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed"); - ); - S.add_route_handler server ~meth:`GET - S.Route.rest_of_path_urlencoded - (fun path req -> - let full_path = dir // path in - let mtime = lazy ( - try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime - with _ -> S.Response.fail_raise ~code:403 "Cannot access file" - ) in - 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 ( - S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime)); - 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); - let parent = Filename.(dirname path) in - let parent = if parent <> path then Some parent else None in - if Sys.file_exists (full_path // "index.html") && config.auto_index_html then ( - (* redirect using path, not full path *) - let new_path = "/" // path // "index.html" in - S._debug (fun k->k "redirect to `%s`" new_path); - S.Response.make_raw ~code:301 "" - ~headers:S.Headers.(empty |> set "location" new_path) - ) else ( - let body = html_list_dir ~top:dir path ~parent in - S.Response.make_string - ~headers:[header_html; "ETag", Lazy.force mtime] - (Ok body) - ) - ) else ( - try - let ic = open_in full_path in - let mime_type = - if Filename.extension full_path = ".css" then ( - ["Content-Type", "text/css"] - ) else if Filename.extension full_path = ".js" then ( - ["Content-Type", "text/javascript"] - ) else try - let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" full_path) in - finally_ ~h:(fun p->ignore @@ Unix.close_process_in p) p - (fun p -> - try ["Content-Type", String.trim (input_line p)] - with _ -> []) - with _ -> [] - in - S.Response.make_raw_stream - ~headers:(mime_type@["Etag", Lazy.force mtime]) - ~code:200 (S.Byte_stream.of_chan ic) - with e -> - S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e) - )); + dir (if S.is_ipv6 server then "[%s]" else "%s") addr port; + + D.add_dir_path ~config ~dir ~prefix:"" server; S.run server let parse_size s : int = @@ -227,26 +20,29 @@ let parse_size s : int = with _ -> raise (Arg.Bad "invalid size (expected [kM]?)") let main () = - let config = default_config () in + let config = D.default_config () in let dir_ = ref "." in + let addr = ref "127.0.0.1" in + let port = ref 8080 in + let j = ref 32 in Arg.parse (Arg.align [ - "--addr", String (fun s -> config.addr <- s), " address to listen on"; - "-a", String (fun s -> config.addr <- s), " alias to --listen"; - "--port", Int (fun x -> config.port <- x), " port to listen on"; - "-p", Int (fun x -> config.port <- x), " alias to --port"; + "--addr", Set_string addr, " address to listen on"; + "-a", Set_string addr, " alias to --listen"; + "--port", Set_int port, " port to listen on"; + "-p", Set_int port, " alias to --port"; "--dir", Set_string dir_, " directory to serve (default: \".\")"; "--debug", Unit (fun () -> S._enable_debug true), " debug mode"; "--upload", Unit (fun () -> config.upload <- true), " enable file uploading"; "--no-upload", Unit (fun () -> config.upload <- false), " disable file uploading"; "--max-upload", String (fun i -> config.max_upload_size <- parse_size i), " maximum size of files that can be uploaded"; - "--auto-index", Bool (fun b -> config.auto_index_html <- b), - " automatically redirect to index.html if present"; + "--auto-index", Unit (fun () -> config.dir_behavior <- Index), + " automatically redirect to index.html if present"; "--delete", Unit (fun () -> config.delete <- true), " enable `delete` on files"; "--no-delete", Unit (fun () -> config.delete <- false), " disable `delete` on files"; - "-j", Int (fun j->config.j <- j), " maximum number of simultaneous connections"; + "-j", Set_int j, " maximum number of simultaneous connections"; ]) (fun s -> dir_ := s) "http_of_dir [options] [dir]"; - match serve ~config !dir_ with + match serve ~config !dir_ !addr !port !j with | Ok () -> () | Error e -> raise e From 8fc22ff07ee6424f4b16bbd3690ac22bd056a52a Mon Sep 17 00:00:00 2001 From: craff Date: Fri, 17 Dec 2021 22:08:01 -1000 Subject: [PATCH 02/14] ignore empty string in exact_path --- src/Tiny_httpd.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index ae836b62..ad416b99 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -752,6 +752,7 @@ module Route = struct let exact_path (s:string) tail = let rec fn = function | [] -> tail + | ""::ls -> fn ls | s::ls -> exact s @/ fn ls in fn (String.split_on_char '/' s) From 0a31d09601f0164b68f833e64840213832833d2a Mon Sep 17 00:00:00 2001 From: craff Date: Fri, 17 Dec 2021 22:13:31 -1000 Subject: [PATCH 03/14] added mem_cache --- src/Tiny_httpd_dir.ml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index d5e1731c..55b70d3a 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -164,6 +164,8 @@ 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)) @@ -173,6 +175,13 @@ let add_dir_path ~config ~dir ~prefix server = try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime with _ -> S.Response.fail_raise ~code:403 "Cannot access file" ) in + try + if not config.mem_cache then raise Not_found; + 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 ( @@ -221,7 +230,11 @@ let add_dir_path ~config ~dir ~prefix server = ~headers:(mime_type@["Etag", Lazy.force mtime]) ~code:200 (S.Byte_stream.of_chan ic) with e -> - S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string 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 S.Route.(exact_path prefix (string @/ return)) From 306712053924176943ec834247f0e021883cd87a Mon Sep 17 00:00:00 2001 From: craff Date: Sun, 19 Dec 2021 00:29:56 -1000 Subject: [PATCH 04/14] use bigstring and map_file --- src/Tiny_httpd.ml | 79 +++++++++++++++++++++++-------- src/Tiny_httpd.mli | 15 +++++- src/Tiny_httpd_dir.ml | 43 +++++++---------- src/Tiny_httpd_dir.mli | 1 - src/camlzip/Tiny_httpd_camlzip.ml | 23 ++++++--- src/dune | 2 +- tests/download_chunked.sh | 9 ++++ 7 files changed, 118 insertions(+), 54 deletions(-) diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index ad416b99..258fdb0f 100644 --- a/src/Tiny_httpd.ml +++ b/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 (`Stream body) -> make_raw_stream ?headers ~code:200 body - | Ok `Void -> make_void ?headers ~code:200 () + | Ok (String body) -> make_raw ?headers ~code:200 body + | Ok (BigString body) -> make_raw_big ?headers ~code:200 body + | 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 - | `Stream _ -> Format.pp_print_string out "" - | `Void -> () + | String s -> Format.fprintf out "%S" s + | BigString _ -> Format.pp_print_string out "" + | Stream _ -> Format.pp_print_string out "" + | 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 - | `String _ as b -> b, false - | `Stream _ as b -> b, true - | `Void as b -> b, false + Stream (Byte_stream.of_string s), true + | BigString s when Bigstring.length s > 1024 * 500 -> + (* chunk-encode large bodies *) + 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 s -> output_string oc s; - | `Stream str -> output_stream_chunked_ oc str; + | String "" | Void -> () + | String s -> output_string oc s; + | 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 diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index 539f440c..aab4b806 100644 --- a/src/Tiny_httpd.mli +++ b/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 -> diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index 55b70d3a..c471d25c 100644 --- a/src/Tiny_httpd_dir.ml +++ b/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 ( - try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime - with _ -> S.Response.fail_raise ~code:403 "Cannot access file" - ) in - try - if not config.mem_cache then raise Not_found; - let (ans, mtime0) = Hashtbl.find cache path in - if mtime <> mtime0 then raise Not_found; - ans - with Not_found -> - let ans = + let stat = + try Unix.stat full_path + with _ -> S.Response.fail_raise ~code:403 "Cannot access file" + in + let mtime = stat.Unix.st_mtime in + let mtime_str = Printf.sprintf "mtime: %f" mtime in 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 ( - S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime)); + ) else + 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 - ~headers:(mime_type@["Etag", Lazy.force mtime]) - ~code:200 (S.Byte_stream.of_chan ic) + S.Response.make_raw_big + ~headers:(mime_type@["Etag", mtime_str]) + ~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 diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli index 57e6dcb2..a5cbf213 100644 --- a/src/Tiny_httpd_dir.mli +++ b/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; diff --git a/src/camlzip/Tiny_httpd_camlzip.ml b/src/camlzip/Tiny_httpd_camlzip.ml index f9a394fc..7bf53f5a 100644 --- a/src/camlzip/Tiny_httpd_camlzip.ml +++ b/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 - diff --git a/src/dune b/src/dune index 29a2fb12..40391f32 100644 --- a/src/dune +++ b/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)) diff --git a/tests/download_chunked.sh b/tests/download_chunked.sh index 2fc4e3c5..ca70f77b 100755 --- a/tests/download_chunked.sh +++ b/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' From 912c7b1fd70428108f82a40172fc710f0aeb5fdc Mon Sep 17 00:00:00 2001 From: craff Date: Sun, 19 Dec 2021 00:49:09 -1000 Subject: [PATCH 05/14] close fd correctly --- src/Tiny_httpd_dir.ml | 13 ++++++------- tests/dl-out.expect | 5 ++++- tests/download_chunked.sh | 8 ++++---- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index c471d25c..748e7abe 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -204,9 +204,10 @@ let add_dir_path ~config ~dir ~prefix server = S.Response.make_raw ~code:405 "listing dir not allowed" ) else ( try - let bs = Bigstring_unix.with_map_file ~flags:[Open_rdonly] full_path - (fun s -> s) - in + let fd = Unix.(openfile full_path [O_RDONLY] 0) in + let len = stat.Unix.st_size in + let bs = Bigstring_unix.map_file_descr fd len in + Gc.finalise (fun _ -> Unix.close fd) bs; let mime_type = if Filename.extension full_path = ".css" then ( ["Content-Type", "text/css"] @@ -224,10 +225,8 @@ let add_dir_path ~config ~dir ~prefix server = ~headers:(mime_type@["Etag", mtime_str]) ~code:200 bs with e -> - S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)) - ) - ) else ( + S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)))) else ( S.add_route_handler server ~meth:`GET S.Route.(exact_path prefix (string @/ return)) (fun _ _ -> S.Response.make_raw ~code:405 "download not allowed"); - ); + ); diff --git a/tests/dl-out.expect b/tests/dl-out.expect index d0e79081..fb1769c9 100644 --- a/tests/dl-out.expect +++ b/tests/dl-out.expect @@ -1,2 +1,5 @@ serve directory . on http://127.0.0.1:8084 - 0 0 52428800 data2 + 0 0 52428800 data21 + 0 0 52428800 data22 + 0 0 52428800 data23 + 0 0 157286400 total diff --git a/tests/download_chunked.sh b/tests/download_chunked.sh index ca70f77b..caa9a8b2 100755 --- a/tests/download_chunked.sh +++ b/tests/download_chunked.sh @@ -8,16 +8,16 @@ PID=$! sleep 0.1 echo download1 1>&2 -curl -N "http://localhost:${PORT}/foo_50" -o data2 \ +curl -N "http://localhost:${PORT}/foo_50" -o data21 \ -H 'Tranfer-encoding: chunked' echo download2 1>&2 -curl -N "http://localhost:${PORT}/foo_50" -o data2 \ +curl -N "http://localhost:${PORT}/foo_50" -o data22 \ -H 'Tranfer-encoding: chunked' echo download3 1>&2 -curl -N "http://localhost:${PORT}/foo_50" -o data2 \ +curl -N "http://localhost:${PORT}/foo_50" -o data23 \ -H 'Tranfer-encoding: chunked' kill $PID -wc data2 +wc data21 data22 data23 From f08406c1ae73ee811458d2bf556810b8a0b8cbf3 Mon Sep 17 00:00:00 2001 From: craff Date: Sun, 19 Dec 2021 00:53:54 -1000 Subject: [PATCH 06/14] Revert "close fd correctly" This reverts commit 912c7b1fd70428108f82a40172fc710f0aeb5fdc. --- src/Tiny_httpd_dir.ml | 13 +++++++------ tests/dl-out.expect | 5 +---- tests/download_chunked.sh | 8 ++++---- 3 files changed, 12 insertions(+), 14 deletions(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index 748e7abe..c471d25c 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -204,10 +204,9 @@ let add_dir_path ~config ~dir ~prefix server = S.Response.make_raw ~code:405 "listing dir not allowed" ) else ( try - let fd = Unix.(openfile full_path [O_RDONLY] 0) in - let len = stat.Unix.st_size in - let bs = Bigstring_unix.map_file_descr fd len in - Gc.finalise (fun _ -> Unix.close fd) bs; + 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"] @@ -225,8 +224,10 @@ let add_dir_path ~config ~dir ~prefix server = ~headers:(mime_type@["Etag", mtime_str]) ~code:200 bs with e -> - S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)))) else ( + S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)) + ) + ) else ( S.add_route_handler server ~meth:`GET S.Route.(exact_path prefix (string @/ return)) (fun _ _ -> S.Response.make_raw ~code:405 "download not allowed"); - ); + ); diff --git a/tests/dl-out.expect b/tests/dl-out.expect index fb1769c9..d0e79081 100644 --- a/tests/dl-out.expect +++ b/tests/dl-out.expect @@ -1,5 +1,2 @@ serve directory . on http://127.0.0.1:8084 - 0 0 52428800 data21 - 0 0 52428800 data22 - 0 0 52428800 data23 - 0 0 157286400 total + 0 0 52428800 data2 diff --git a/tests/download_chunked.sh b/tests/download_chunked.sh index caa9a8b2..ca70f77b 100755 --- a/tests/download_chunked.sh +++ b/tests/download_chunked.sh @@ -8,16 +8,16 @@ PID=$! sleep 0.1 echo download1 1>&2 -curl -N "http://localhost:${PORT}/foo_50" -o data21 \ +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 data22 \ +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 data23 \ +curl -N "http://localhost:${PORT}/foo_50" -o data2 \ -H 'Tranfer-encoding: chunked' kill $PID -wc data21 data22 data23 +wc data2 From 6dceabdd6ccaa0989e1923a4ee14d3c581fa91d7 Mon Sep 17 00:00:00 2001 From: craff Date: Sun, 19 Dec 2021 00:54:17 -1000 Subject: [PATCH 07/14] Revert "use bigstring and map_file" This reverts commit 306712053924176943ec834247f0e021883cd87a. --- src/Tiny_httpd.ml | 79 ++++++++----------------------- src/Tiny_httpd.mli | 15 +----- src/Tiny_httpd_dir.ml | 43 ++++++++++------- src/Tiny_httpd_dir.mli | 1 + src/camlzip/Tiny_httpd_camlzip.ml | 23 +++------ src/dune | 2 +- tests/download_chunked.sh | 9 ---- 7 files changed, 54 insertions(+), 118 deletions(-) diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index 258fdb0f..ad416b99 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -107,7 +107,6 @@ 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); @@ -117,29 +116,6 @@ 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 @@ -615,9 +591,7 @@ end *) module Response = struct - type body = - | String of string | BigString of Bigstring.t - | Stream of byte_stream | Void + type body = [`String of string | `Stream of byte_stream | `Void] type t = { code: Response_code.t; headers: Headers.t; @@ -635,22 +609,15 @@ module Response = struct let headers = Headers.set "Content-Length" (string_of_int (String.length body)) headers in - { 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; } + { code; headers; body=`String 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 @@ -661,10 +628,9 @@ 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 (BigString body) -> make_raw_big ?headers ~code:200 body - | Ok (Stream body) -> make_raw_stream ?headers ~code:200 body - | Ok Void -> make_void ?headers ~code:200 () + | Ok (`String body) -> make_raw ?headers ~code:200 body + | 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 = @@ -674,10 +640,9 @@ module Response = struct let pp out self : unit = let pp_body out = function - | String s -> Format.fprintf out "%S" s - | BigString _ -> Format.pp_print_string out "" - | Stream _ -> Format.pp_print_string out "" - | Void -> () + | `String s -> Format.fprintf out "%S" s + | `Stream _ -> Format.pp_print_string out "" + | `Void -> () in Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" self.code Headers.pp self.headers pp_body self.body @@ -701,16 +666,12 @@ 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 - | BigString s when Bigstring.length s > 1024 * 500 -> - (* chunk-encode large bodies *) - 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 + `Stream (Byte_stream.of_string s), true + | `String _ as b -> b, false + | `Stream _ as b -> b, true + | `Void as b -> b, false in let headers = if is_chunked then ( @@ -721,15 +682,13 @@ 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 s -> output_string oc s; - | BigString s -> Format.fprintf (Format.formatter_of_out_channel oc) - "%a%!" Bigstring.print s - | Stream str -> output_stream_chunked_ oc str; + | `String "" | `Void -> () + | `String s -> output_string oc s; + | `Stream str -> output_stream_chunked_ oc str; end; flush oc end diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index aab4b806..539f440c 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -141,9 +141,6 @@ 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 *) @@ -334,9 +331,7 @@ end the client to answer a {!Request.t}*) module Response : sig - type body = - | String of string | BigString of Bigstring.t - | Stream of byte_stream | Void + type body = [`String of string | `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). *) @@ -375,14 +370,6 @@ 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 -> diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index c471d25c..55b70d3a 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -7,6 +7,7 @@ type dir_behavior = type config = { mutable download: bool; + mutable mem_cache: bool; mutable dir_behavior: dir_behavior; mutable delete: bool; mutable upload: bool; @@ -15,6 +16,7 @@ type config = { let default_config () : config = { download=true + ; mem_cache=false ; dir_behavior=Forbidden ; delete=false ; upload=false @@ -41,7 +43,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] = '.' @@ -162,24 +164,30 @@ 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 stat = - try Unix.stat full_path - with _ -> S.Response.fail_raise ~code:403 "Cannot access file" - in - let mtime = stat.Unix.st_mtime in - let mtime_str = Printf.sprintf "mtime: %f" mtime in + let mtime = lazy ( + try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime + with _ -> S.Response.fail_raise ~code:403 "Cannot access file" + ) in + try + if not config.mem_cache then raise Not_found; + 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 mtime_str then ( - S._debug (fun k->k "cached object %S (etag: %S)" path mtime_str); + ) else if S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime) then ( + S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime)); 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); @@ -198,15 +206,13 @@ 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", mtime_str] + ~headers:[header_html; "ETag", Lazy.force mtime] (Ok body) | Forbidden -> S.Response.make_raw ~code:405 "listing dir not allowed" ) else ( try - let bs = Bigstring_unix.with_map_file ~flags:[Open_rdonly] full_path - (fun s -> s) - in + let ic = open_in full_path in let mime_type = if Filename.extension full_path = ".css" then ( ["Content-Type", "text/css"] @@ -220,11 +226,14 @@ let add_dir_path ~config ~dir ~prefix server = with _ -> []) with _ -> [] in - S.Response.make_raw_big - ~headers:(mime_type@["Etag", mtime_str]) - ~code:200 bs + S.Response.make_raw_stream + ~headers:(mime_type@["Etag", Lazy.force mtime]) + ~code:200 (S.Byte_stream.of_chan ic) 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 diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli index a5cbf213..57e6dcb2 100644 --- a/src/Tiny_httpd_dir.mli +++ b/src/Tiny_httpd_dir.mli @@ -4,6 +4,7 @@ type dir_behavior = type config = { mutable download: bool; + mutable mem_cache: bool; mutable dir_behavior: dir_behavior; mutable delete: bool; mutable upload: bool; diff --git a/src/camlzip/Tiny_httpd_camlzip.ml b/src/camlzip/Tiny_httpd_camlzip.ml index 7bf53f5a..f9a394fc 100644 --- a/src/camlzip/Tiny_httpd_camlzip.ml +++ b/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,27 +188,15 @@ let compress_resp_stream_ in resp |> S.Response.update_headers update_headers - |> S.Response.set_body (Stream body) + |> S.Response.set_body (`Stream body) - | 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 -> + | `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 _ | BigString _ | Void -> resp + | `String _ | `Void -> resp ) else resp let middleware @@ -227,3 +215,4 @@ 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 + diff --git a/src/dune b/src/dune index 40391f32..29a2fb12 100644 --- a/src/dune +++ b/src/dune @@ -2,6 +2,6 @@ (library (name tiny_httpd) (public_name tiny_httpd) - (libraries threads bigstring bigstring-unix) + (libraries threads) (flags :standard -safe-string -warn-error -a+8) (wrapped false)) diff --git a/tests/download_chunked.sh b/tests/download_chunked.sh index ca70f77b..2fc4e3c5 100755 --- a/tests/download_chunked.sh +++ b/tests/download_chunked.sh @@ -7,15 +7,6 @@ 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' From 7e236058f70d69e975a51240a28bf5575758f4fb Mon Sep 17 00:00:00 2001 From: craff Date: Sun, 19 Dec 2021 00:58:03 -1000 Subject: [PATCH 08/14] remove mem cache ... not really usefull to gain speed --- src/Tiny_httpd_dir.ml | 16 +--------------- src/Tiny_httpd_dir.mli | 1 - tests/dl-out.expect | 5 ++++- tests/download_chunked.sh | 13 +++++++++++-- 4 files changed, 16 insertions(+), 19 deletions(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index 55b70d3a..f659bbaa 100644 --- a/src/Tiny_httpd_dir.ml +++ b/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,8 +162,6 @@ 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)) @@ -175,13 +171,6 @@ let add_dir_path ~config ~dir ~prefix server = try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime with _ -> S.Response.fail_raise ~code:403 "Cannot access file" ) in - try - if not config.mem_cache then raise Not_found; - 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 ( @@ -231,9 +220,6 @@ let add_dir_path ~config ~dir ~prefix server = ~code:200 (S.Byte_stream.of_chan ic) 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 diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli index 57e6dcb2..a5cbf213 100644 --- a/src/Tiny_httpd_dir.mli +++ b/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; diff --git a/tests/dl-out.expect b/tests/dl-out.expect index d0e79081..fb1769c9 100644 --- a/tests/dl-out.expect +++ b/tests/dl-out.expect @@ -1,2 +1,5 @@ serve directory . on http://127.0.0.1:8084 - 0 0 52428800 data2 + 0 0 52428800 data21 + 0 0 52428800 data22 + 0 0 52428800 data23 + 0 0 157286400 total diff --git a/tests/download_chunked.sh b/tests/download_chunked.sh index 2fc4e3c5..caa9a8b2 100755 --- a/tests/download_chunked.sh +++ b/tests/download_chunked.sh @@ -7,8 +7,17 @@ PID=$! sleep 0.1 -curl -N "http://localhost:${PORT}/foo_50" -o data2 \ +echo download1 1>&2 +curl -N "http://localhost:${PORT}/foo_50" -o data21 \ + -H 'Tranfer-encoding: chunked' + +echo download2 1>&2 +curl -N "http://localhost:${PORT}/foo_50" -o data22 \ + -H 'Tranfer-encoding: chunked' + +echo download3 1>&2 +curl -N "http://localhost:${PORT}/foo_50" -o data23 \ -H 'Tranfer-encoding: chunked' kill $PID -wc data2 +wc data21 data22 data23 From fe0da80f2fc678e9fd1eaec94dfd60d8608f98db Mon Sep 17 00:00:00 2001 From: craff Date: Sun, 19 Dec 2021 19:30:25 -1000 Subject: [PATCH 09/14] Documentation in Tiny_httpd_dir.mli + new dir mode IndexAndLists --- src/Tiny_httpd_dir.ml | 22 ++++++++++------------ src/Tiny_httpd_dir.mli | 21 ++++++++++++++++++++- src/bin/http_of_dir.ml | 6 ++++++ 3 files changed, 36 insertions(+), 13 deletions(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index f659bbaa..d7edcae9 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -3,7 +3,7 @@ module U = Tiny_httpd_util module Pf = Printf type dir_behavior = - Index | Forbidden | Lists + Index | Lists | IndexAndLists | Forbidden type config = { mutable download: bool; @@ -183,21 +183,19 @@ let add_dir_path ~config ~dir ~prefix server = let parent = Filename.(dirname path) in let parent = if parent <> path then Some parent else None in match config.dir_behavior with - | Index -> - if Sys.file_exists (full_path // "index.html") then ( - (* redirect using path, not full path *) - let new_path = "/" // path // "index.html" in - S._debug (fun k->k "redirect to `%s`" new_path); - S.Response.make_raw ~code:301 "" - ~headers:S.Headers.(empty |> set "location" new_path)) - else - S.Response.fail_raise ~code:403 "Cannot access file" - | Lists -> + | Index | IndexAndLists when + Sys.file_exists (full_path // "index.html") -> + (* redirect using path, not full path *) + let new_path = "/" // path // "index.html" in + S._debug (fun k->k "redirect to `%s`" new_path); + S.Response.make_raw ~code:301 "" + ~headers:S.Headers.(empty |> set "location" new_path) + | Lists | IndexAndLists -> let body = html_list_dir ~top:dir path ~parent in S.Response.make_string ~headers:[header_html; "ETag", Lazy.force mtime] (Ok body) - | Forbidden -> + | Forbidden | Index -> S.Response.make_raw ~code:405 "listing dir not allowed" ) else ( try diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli index a5cbf213..877b7d77 100644 --- a/src/Tiny_httpd_dir.mli +++ b/src/Tiny_httpd_dir.mli @@ -1,7 +1,16 @@ +(** behavior of static directory *) type dir_behavior = - Index | Forbidden | Lists + | Index + (** Redirect to index.html if present *) + | Lists + (** Lists content of directory *) + | IndexAndLists + (** Redirect to index.html if present and Lists content otherwise *) + | Forbidden + (** Forbid access to directory *) +(** configuration for static file handlers *) type config = { mutable download: bool; mutable dir_behavior: dir_behavior; @@ -10,8 +19,18 @@ type config = { mutable max_upload_size: int; } +(** default configuration: [ + { download=true + ; dir_behavior=Forbidden + ; delete=false + ; upload=false + ; max_upload_size = 10 * 1024 * 1024 + }] *) val default_config : unit -> config +(** [add_dirpath ~config ~dir ~prefix server] adds route handle to the + [server] to serve static files in [dir] when url starts with [prefix], + using the given configuration [config]. *) val add_dir_path : config:config -> dir:string -> prefix:string -> diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index 252cfd10..17c44f64 100644 --- a/src/bin/http_of_dir.ml +++ b/src/bin/http_of_dir.ml @@ -34,10 +34,16 @@ let main () = "--debug", Unit (fun () -> S._enable_debug true), " debug mode"; "--upload", Unit (fun () -> config.upload <- true), " enable file uploading"; "--no-upload", Unit (fun () -> config.upload <- false), " disable file uploading"; + "--download", Unit (fun () -> config.download <- true), " enable file downloading"; + "--no-download", Unit (fun () -> config.download <- false), " disable file downloading"; "--max-upload", String (fun i -> config.max_upload_size <- parse_size i), " maximum size of files that can be uploaded"; "--auto-index", Unit (fun () -> config.dir_behavior <- Index), " automatically redirect to index.html if present"; + "--list-dir", Unit (fun () -> config.dir_behavior <- Lists), + " automatically lists directory"; + "--index-and-list", Unit (fun () -> config.dir_behavior <- IndexAndLists), + " automatically redirect to index.html or lists directory"; "--delete", Unit (fun () -> config.delete <- true), " enable `delete` on files"; "--no-delete", Unit (fun () -> config.delete <- false), " disable `delete` on files"; "-j", Set_int j, " maximum number of simultaneous connections"; From ce4b5f0a117545c57eb8f64ece8cd90639b05182 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Dec 2021 09:49:44 -0500 Subject: [PATCH 10/14] some small code improvements --- src/Tiny_httpd.mli | 3 ++- src/Tiny_httpd_dir.ml | 10 +++++----- src/Tiny_httpd_dir.mli | 2 +- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index 539f440c..5cac900d 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -456,7 +456,8 @@ module Route : sig val exact_path : string -> ('a,'b) t -> ('a,'b) t (** [exact_path "foo/bar/..." r] is equivalent to - [exact "foo" @/ exact "bar" @/ ... @/ r] **) + [exact "foo" @/ exact "bar" @/ ... @/ r] + @since NEXT_RELEASE **) val pp : Format.formatter -> _ t -> unit (** Print the route. diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index d7edcae9..c26c5a95 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -14,11 +14,11 @@ type config = { } let default_config () : config = - { download=true - ; dir_behavior=Forbidden - ; delete=false - ; upload=false - ; max_upload_size = 10 * 1024 * 1024 + { download=true; + dir_behavior=Forbidden; + delete=false; + upload=false; + max_upload_size = 10 * 1024 * 1024; } let contains_dot_dot s = diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli index 877b7d77..cf8a332c 100644 --- a/src/Tiny_httpd_dir.mli +++ b/src/Tiny_httpd_dir.mli @@ -5,7 +5,7 @@ type dir_behavior = (** Redirect to index.html if present *) | Lists (** Lists content of directory *) - | IndexAndLists + | Index_or_lists (** Redirect to index.html if present and Lists content otherwise *) | Forbidden (** Forbid access to directory *) From e1ddb96e7c703a9fc31436bf9363122a22766077 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Dec 2021 09:52:23 -0500 Subject: [PATCH 11/14] Update src/Tiny_httpd_dir.ml --- src/Tiny_httpd_dir.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index c26c5a95..33da8535 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -34,7 +34,7 @@ let contains_dot_dot s = let human_size (x:int) : string = if x >= 1_000_000_000 then Printf.sprintf "%d.%dG" (x / 1_000_000_000) ((x/1_000_000) mod 1_000_000) else if x >= 1_000_000 then Printf.sprintf "%d.%dM" (x / 1_000_000) ((x/1000) mod 1_000) - else if x >= 1_000 then Printf.sprintf "%d.%dk" (x/1000) ((x/100) mod 10) + else if x >= 1_000 then Printf.sprintf "%d.%dk" (x/1000) ((x/100) mod 100) else Printf.sprintf "%db" x let header_html = "Content-Type", "text/html" From bf2bf6832de3acc56c5aa98a2f058812382d86b5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Dec 2021 09:53:19 -0500 Subject: [PATCH 12/14] code cleanup --- src/Tiny_httpd_dir.ml | 153 +++++++++++++++++++---------------------- src/bin/http_of_dir.ml | 2 +- 2 files changed, 73 insertions(+), 82 deletions(-) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index 33da8535..3aadfdc6 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -3,7 +3,7 @@ module U = Tiny_httpd_util module Pf = Printf type dir_behavior = - Index | Lists | IndexAndLists | Forbidden + | Index | Lists | Index_or_lists | Forbidden type config = { mutable download: bool; @@ -25,7 +25,7 @@ let contains_dot_dot s = try String.iteri (fun i c -> - if c='.' && i+1 < String.length s && String.get s (i+1) = '.' then raise Exit) + if c='.' && i+1 < String.length s && String.get s (i+1) = '.' then raise Exit) s; false with Exit -> true @@ -100,29 +100,20 @@ let finally_ ~h x f = h x; raise e -(* TODO -let wdays = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|] -let date_of_time (f:float) : string = - let open Unix in - let t = Unix.gmtime f in - Printf.sprintf "%s, %02d %d %d %d:%d:%d GMT" - wdays.(t.tm_yday) t.tm_mday t.tm_mon t.tm_year t.tm_hour t.tm_min t.tm_sec - *) - let add_dir_path ~config ~dir ~prefix server = if config.delete then ( S.add_route_handler server ~meth:`DELETE S.Route.(exact_path prefix (rest_of_path_urlencoded)) (fun path _req -> - if contains_dot_dot path then ( - S.Response.fail_raise ~code:403 "invalid path in delete" - ) else ( - S.Response.make_string - (try - Sys.remove (dir // path); Ok "file deleted successfully" - with e -> Error (500, Printexc.to_string e)) - ) + if contains_dot_dot path then ( + S.Response.fail_raise ~code:403 "invalid path in delete" + ) else ( + S.Response.make_string + (try + Sys.remove (dir // path); Ok "file deleted successfully" + with e -> Error (500, Printexc.to_string e)) + ) ); ) else ( S.add_route_handler server ~meth:`DELETE @@ -134,93 +125,93 @@ let add_dir_path ~config ~dir ~prefix server = S.add_route_handler_stream server ~meth:`PUT S.Route.(exact_path prefix (rest_of_path_urlencoded)) ~accept:(fun req -> - match S.Request.get_header_int req "Content-Length" with - | Some n when n > config.max_upload_size -> - Error (403, "max upload size is " ^ string_of_int config.max_upload_size) - | Some _ when contains_dot_dot req.S.Request.path -> - Error (403, "invalid path (contains '..')") - | _ -> Ok () - ) + match S.Request.get_header_int req "Content-Length" with + | Some n when n > config.max_upload_size -> + Error (403, "max upload size is " ^ string_of_int config.max_upload_size) + | Some _ when contains_dot_dot req.S.Request.path -> + Error (403, "invalid path (contains '..')") + | _ -> Ok () + ) (fun path req -> - let fpath = dir // path in - let oc = - try open_out fpath - with e -> - S.Response.fail_raise ~code:403 "cannot upload to %S: %s" - path (Printexc.to_string e) - in - let req = S.Request.limit_body_size ~max_size:config.max_upload_size req in - S.Byte_stream.to_chan oc req.S.Request.body; - flush oc; - close_out oc; - S._debug (fun k->k "done uploading"); - S.Response.make_raw ~code:201 "upload successful" + let fpath = dir // path in + let oc = + try open_out fpath + with e -> + S.Response.fail_raise ~code:403 "cannot upload to %S: %s" + path (Printexc.to_string e) + in + let req = S.Request.limit_body_size ~max_size:config.max_upload_size req in + S.Byte_stream.to_chan oc req.S.Request.body; + flush oc; + close_out oc; + S._debug (fun k->k "done uploading"); + S.Response.make_raw ~code:201 "upload successful" ) ) else ( S.add_route_handler server ~meth:`PUT S.Route.(exact_path prefix (string @/ return)) - (fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed"); + (fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed"); ); 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 ( - try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime - with _ -> S.Response.fail_raise ~code:403 "Cannot access file" - ) in - 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 ( - S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime)); - 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); - let parent = Filename.(dirname path) in - let parent = if parent <> path then Some parent else None in - match config.dir_behavior with - | Index | IndexAndLists when - Sys.file_exists (full_path // "index.html") -> + let full_path = dir // path in + let mtime = lazy ( + try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime + with _ -> S.Response.fail_raise ~code:403 "Cannot access file" + ) in + 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 ( + S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime)); + 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); + let parent = Filename.(dirname path) in + let parent = if parent <> path then Some parent else None in + match config.dir_behavior with + | Index | Index_or_lists when + Sys.file_exists (full_path // "index.html") -> (* redirect using path, not full path *) let new_path = "/" // path // "index.html" in S._debug (fun k->k "redirect to `%s`" new_path); S.Response.make_raw ~code:301 "" ~headers:S.Headers.(empty |> set "location" new_path) - | Lists | IndexAndLists -> + | Lists | Index_or_lists -> let body = html_list_dir ~top:dir path ~parent in S.Response.make_string ~headers:[header_html; "ETag", Lazy.force mtime] (Ok body) - | Forbidden | Index -> + | Forbidden | Index -> S.Response.make_raw ~code:405 "listing dir not allowed" - ) else ( - try - let ic = open_in full_path in - let mime_type = - if Filename.extension full_path = ".css" then ( - ["Content-Type", "text/css"] - ) else if Filename.extension full_path = ".js" then ( - ["Content-Type", "text/javascript"] - ) else try - let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" full_path) in - finally_ ~h:(fun p->ignore @@ Unix.close_process_in p) p - (fun p -> + ) else ( + try + let ic = open_in full_path in + let mime_type = + if Filename.extension full_path = ".css" then ( + ["Content-Type", "text/css"] + ) else if Filename.extension full_path = ".js" then ( + ["Content-Type", "text/javascript"] + ) else try + let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" full_path) in + finally_ ~h:(fun p->ignore @@ Unix.close_process_in p) p + (fun p -> try ["Content-Type", String.trim (input_line p)] with _ -> []) - with _ -> [] - in - S.Response.make_raw_stream - ~headers:(mime_type@["Etag", Lazy.force mtime]) - ~code:200 (S.Byte_stream.of_chan ic) - with e -> - S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)) + with _ -> [] + in + S.Response.make_raw_stream + ~headers:(mime_type@["Etag", Lazy.force mtime]) + ~code:200 (S.Byte_stream.of_chan ic) + with e -> + S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)) ) ) else ( S.add_route_handler server ~meth:`GET S.Route.(exact_path prefix (string @/ return)) - (fun _ _ -> S.Response.make_raw ~code:405 "download not allowed"); + (fun _ _ -> S.Response.make_raw ~code:405 "download not allowed"); ); diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index 17c44f64..376cb17b 100644 --- a/src/bin/http_of_dir.ml +++ b/src/bin/http_of_dir.ml @@ -42,7 +42,7 @@ let main () = " automatically redirect to index.html if present"; "--list-dir", Unit (fun () -> config.dir_behavior <- Lists), " automatically lists directory"; - "--index-and-list", Unit (fun () -> config.dir_behavior <- IndexAndLists), + "--index-and-list", Unit (fun () -> config.dir_behavior <- Index_or_lists), " automatically redirect to index.html or lists directory"; "--delete", Unit (fun () -> config.delete <- true), " enable `delete` on files"; "--no-delete", Unit (fun () -> config.delete <- false), " disable `delete` on files"; From 5735f813a5c1ed3e3e8926604396316dbab23f30 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Dec 2021 09:59:31 -0500 Subject: [PATCH 13/14] restore previous behavior for http_of_dir --- src/bin/http_of_dir.ml | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index 376cb17b..395efe26 100644 --- a/src/bin/http_of_dir.ml +++ b/src/bin/http_of_dir.ml @@ -20,7 +20,8 @@ let parse_size s : int = with _ -> raise (Arg.Bad "invalid size (expected [kM]?)") let main () = - let config = D.default_config () in + let config = D.default_config() in + config.dir_behavior <- Index_or_lists; (* keep old behavior *) let dir_ = ref "." in let addr = ref "127.0.0.1" in let port = ref 8080 in @@ -38,12 +39,10 @@ let main () = "--no-download", Unit (fun () -> config.download <- false), " disable file downloading"; "--max-upload", String (fun i -> config.max_upload_size <- parse_size i), " maximum size of files that can be uploaded"; - "--auto-index", Unit (fun () -> config.dir_behavior <- Index), - " automatically redirect to index.html if present"; - "--list-dir", Unit (fun () -> config.dir_behavior <- Lists), - " automatically lists directory"; - "--index-and-list", Unit (fun () -> config.dir_behavior <- Index_or_lists), - " automatically redirect to index.html or lists directory"; + "--auto-index", + Bool (fun b -> config.dir_behavior <- + (if b then Index_or_lists else Lists)), + " automatically redirect to index.html if present"; "--delete", Unit (fun () -> config.delete <- true), " enable `delete` on files"; "--no-delete", Unit (fun () -> config.delete <- false), " disable `delete` on files"; "-j", Set_int j, " maximum number of simultaneous connections"; From e225212dba4fd49f83211c63b0681100b90375ae Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Dec 2021 10:04:09 -0500 Subject: [PATCH 14/14] more doc --- src/Tiny_httpd_dir.mli | 42 +++++++++++++++++++++++++++++++++--------- 1 file changed, 33 insertions(+), 9 deletions(-) diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli index cf8a332c..9697eb89 100644 --- a/src/Tiny_httpd_dir.mli +++ b/src/Tiny_httpd_dir.mli @@ -1,22 +1,45 @@ -(** behavior of static directory *) +(** Serving static content from directories + + This module provides the same functionality as the "http_of_dir" tool. + It exposes a directory (and its subdirectories), with the optional ability + to delete or upload files. + + @since NEXT_RELEASE *) + +(** behavior of static directory. + + This controls what happens when the user requests the path to + a directory rather than a file. *) type dir_behavior = | Index - (** Redirect to index.html if present *) + (** Redirect to index.html if present, else fails. *) | Lists - (** Lists content of directory *) + (** Lists content of directory. Be careful of security implications. *) | Index_or_lists - (** Redirect to index.html if present and Lists content otherwise *) + (** Redirect to index.html if present and lists content otherwise. + This is useful for tilde ("~") directories and other per-user behavior, + but be mindful of security implications *) | Forbidden - (** Forbid access to directory *) + (** Forbid access to directory. This is suited for serving assets, for example. *) (** configuration for static file handlers *) type config = { mutable download: bool; + (** Is downloading files allowed? *) + mutable dir_behavior: dir_behavior; + (** Behavior when serving a directory and not a file *) + mutable delete: bool; + (** Is deleting a file allowed? (with method DELETE) *) + mutable upload: bool; + (** Is uploading a file allowed? (with method PUT) *) + mutable max_upload_size: int; + (** If {!upload} is true, this is the maximum size in bytes for + uploaded files. *) } (** default configuration: [ @@ -31,7 +54,8 @@ val default_config : unit -> config (** [add_dirpath ~config ~dir ~prefix server] adds route handle to the [server] to serve static files in [dir] when url starts with [prefix], using the given configuration [config]. *) -val add_dir_path : config:config -> - dir:string -> - prefix:string -> - Tiny_httpd.t -> unit +val add_dir_path : + config:config -> + dir:string -> + prefix:string -> + Tiny_httpd.t -> unit