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

feat: use more precise error codes; improve http_of_dir

Browse source
This commit is contained in:
Simon Cruanes 2019-11-17 17:36:04 -06:00
parent 7f68812312
commit 460492ded0
2 changed files with 34 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
src/Tiny_httpd.ml
View file

@ -26,11 +26,24 @@ module Response_code = struct
let descr = function
| 100 -> "Continue"
| 200 -> "OK"
| 201 -> "Created"
| 202 -> "Accepted"
| 204 -> "No content"
| 300 -> "Multiple choices"
| 301 -> "Moved permanently"
| 302 -> "Found"
| 400 -> "Bad request"
| 403 -> "Forbidden"
| 404 -> "Not found"
| 405 -> "Method not allowed"
| 408 -> "Request timeout"
| 409 -> "Conflict"
| 410 -> "Gone"
| 411 -> "Length required"
| 413 -> "Payload too large"
| 417 -> "Expectation failed"
| 500 -> "Internal server error"
| 501 -> "Not implemented"
| 503 -> "Service unavailable"
| _ -> "Unknown response" (* TODO *)
end
@ -146,7 +159,7 @@ module Request = struct
let new_size = chunk_size + !n in
(* is the body bigger than expected? *)
if max_size>0 && new_size > max_size then (
bad_reqf 400
bad_reqf 413
"body size was supposed to be %d, but at least %d bytes received"
max_size new_size
);

37
src/bin/http_of_dir.ml
View file

@ -33,12 +33,16 @@ let (//) = Filename.concat
let html_list_dir ~top ~parent d : string =
let entries = Sys.readdir @@ (top // d) in
let body = Buffer.create 256 in
Printf.bprintf body "<ul>\n";
Printf.bprintf body {|<head><title> http_of_dir %S</title>
</head><body>
<h2> Index of %S</h2>
|} top d;
begin match parent with
| None -> ()
| Some p ->
Printf.bprintf body " <li> <a href=\"/%s\"> (parent directory) </a> </li>\n" p;
Printf.bprintf body "<a href=\"/%s\"> (parent directory) </a>\n" p;
end;
Printf.bprintf body "<ul>\n";
Array.iter
(fun f ->
if not @@ contains_dot_dot (d // f) then (
@ -47,13 +51,9 @@ let html_list_dir ~top ~parent d : string =
)
)
entries;
Printf.bprintf body "</ul>\n";
Printf.bprintf body "</ul></body>\n";
Buffer.contents body
let same_path a b =
Filename.dirname a = Filename.dirname b &&
Filename.basename a = Filename.basename b
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
@ -68,6 +68,9 @@ let serve ~config (dir:string) : _ result =
Sys.remove (dir // path); Ok "file deleted successfully"
with e -> Error (500, Printexc.to_string e))
);
) else (
S.add_path_handler server ~meth:`DELETE "/%s"
(fun _ _ -> S.Response.make_raw ~code:405 "delete not allowed");
);
if config.upload then (
S.add_path_handler server ~meth:`PUT "/%s"
@ -79,7 +82,7 @@ let serve ~config (dir:string) : _ result =
Error (403, "invalid path (contains '..')")
| Some _ -> Ok ()
| None ->
Error (403, "must know size before hand: max upload size is " ^
Error (411, "must know size before hand: max upload size is " ^
string_of_int config.max_upload_size)
)
(fun path req ->
@ -93,24 +96,24 @@ let serve ~config (dir:string) : _ result =
output_string oc req.S.Request.body;
flush oc;
close_out oc;
S.Response.make (Ok "upload successful")
S.Response.make_raw ~code:201 "upload successful"
)
) else (
S.add_path_handler server ~meth:`PUT "/%s"
(fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed");
);
S.add_path_handler server ~meth:`GET "/%s"
(fun path _req ->
let path_dir = Filename.dirname path in
let path_f = Filename.basename path in
let full_path = dir // path_dir // path_f in
let full_path = dir // path 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";
S.Response.fail ~code:404 "File not found";
) else if Sys.is_directory full_path then (
S._debug (fun k->k "list dir %S (topdir %S)" full_path dir);
let body =
html_list_dir ~top:dir path
~parent:(if same_path full_path dir then None else Some dir)
in
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 ~headers:[header_html] (Ok body)
) else (
try