simon/tiny_httpd
1
0
Fork 0
mirror of https://github.com/c-cube/tiny_httpd.git synced 2025-12-06 03:05:29 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

feat(http_of_dir): basic cache control with mtime in etag

Browse source
This commit is contained in:
Simon Cruanes 2019-11-18 20:19:57 -06:00
parent 506292c587
commit 3048bfcc82
2 changed files with 26 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/Tiny_httpd.ml
View file

@ -179,6 +179,7 @@ module Response_code = struct
| 300 -> "Multiple choices"
| 301 -> "Moved permanently"
| 302 -> "Found"
| 304 -> "Not Modified"
| 400 -> "Bad request"
| 403 -> "Forbidden"
| 404 -> "Not found"

30
src/bin/http_of_dir.ml
View file

@ -39,7 +39,7 @@ let html_list_dir ~top ~parent d : string =
|} top d;
begin match parent with
| None -> ()
| Some p ->
| Some p ->
Printf.bprintf body "<a href=\"/%s\"> (parent directory) </a>\n" p;
end;
Printf.bprintf body "<ul>\n";
@ -54,7 +54,16 @@ let html_list_dir ~top ~parent d : string =
Printf.bprintf body "</ul></body>\n";
Buffer.contents body
let serve ~config (dir:string) : _ result =
(* 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 =
Printf.printf "serve directory %s on http://%s:%d\n%!" dir config.addr config.port;
let server = S.create ~addr:config.addr ~port:config.port () in
if config.delete then (
@ -103,22 +112,33 @@ let serve ~config (dir:string) : _ result =
(fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed");
);
S.add_path_handler server ~meth:`GET "/%s"
(fun path _req ->
(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
let body = html_list_dir ~top:dir path ~parent in
S.Response.make_string ~headers:[header_html] (Ok body)
S.Response.make_string
~headers:[header_html; "ETag", Lazy.force mtime]
(Ok body)
) else (
try
let ic = open_in full_path in
S.Response.make_raw_stream ~code:200 (S.Stream_.of_chan ic)
S.Response.make_raw_stream
~headers:["Etag", Lazy.force mtime]
~code:200 (S.Stream_.of_chan ic)
with e ->
S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)
));