simon/tiny_httpd
1
0
Fork 0
mirror of https://github.com/c-cube/tiny_httpd.git synced 2025-12-06 19:25:32 -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 let descr = function
| 100 -> "Continue" | 100 -> "Continue"
| 200 -> "OK" | 200 -> "OK"
| 201 -> "Created"
| 202 -> "Accepted"
| 204 -> "No content"
| 300 -> "Multiple choices"
| 301 -> "Moved permanently"
| 302 -> "Found"
| 400 -> "Bad request" | 400 -> "Bad request"
| 403 -> "Forbidden" | 403 -> "Forbidden"
| 404 -> "Not found" | 404 -> "Not found"
| 405 -> "Method not allowed"
| 408 -> "Request timeout"
| 409 -> "Conflict"
| 410 -> "Gone"
| 411 -> "Length required"
| 413 -> "Payload too large"
| 417 -> "Expectation failed" | 417 -> "Expectation failed"
| 500 -> "Internal server error" | 500 -> "Internal server error"
| 501 -> "Not implemented"
| 503 -> "Service unavailable" | 503 -> "Service unavailable"
| _ -> "Unknown response" (* TODO *) | _ -> "Unknown response" (* TODO *)
end end
@ -146,7 +159,7 @@ module Request = struct
let new_size = chunk_size + !n in let new_size = chunk_size + !n in
(* is the body bigger than expected? *) (* is the body bigger than expected? *)
if max_size>0 && new_size > max_size then ( 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" "body size was supposed to be %d, but at least %d bytes received"
max_size new_size 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 html_list_dir ~top ~parent d : string =
let entries = Sys.readdir @@ (top // d) in let entries = Sys.readdir @@ (top // d) in
let body = Buffer.create 256 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 begin match parent with
| None -> () | None -> ()
| Some p -> | 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; end;
Printf.bprintf body "<ul>\n";
Array.iter Array.iter
(fun f -> (fun f ->
if not @@ contains_dot_dot (d // f) then ( if not @@ contains_dot_dot (d // f) then (
@ -47,13 +51,9 @@ let html_list_dir ~top ~parent d : string =
) )
) )
entries; entries;
Printf.bprintf body "</ul>\n"; Printf.bprintf body "</ul></body>\n";
Buffer.contents body 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 = let serve ~config (dir:string) : _ result =
Printf.printf "serve directory %s on http://%s:%d\n%!" dir config.addr config.port; 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 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" Sys.remove (dir // path); Ok "file deleted successfully"
with e -> Error (500, Printexc.to_string e)) 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 ( if config.upload then (
S.add_path_handler server ~meth:`PUT "/%s" S.add_path_handler server ~meth:`PUT "/%s"
@ -79,7 +82,7 @@ let serve ~config (dir:string) : _ result =
Error (403, "invalid path (contains '..')") Error (403, "invalid path (contains '..')")
| Some _ -> Ok () | Some _ -> Ok ()
| None -> | 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) string_of_int config.max_upload_size)
) )
(fun path req -> (fun path req ->
@ -93,24 +96,24 @@ let serve ~config (dir:string) : _ result =
output_string oc req.S.Request.body; output_string oc req.S.Request.body;
flush oc; flush oc;
close_out 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" S.add_path_handler server ~meth:`GET "/%s"
(fun path _req -> (fun path _req ->
let path_dir = Filename.dirname path in let full_path = dir // path in
let path_f = Filename.basename path in
let full_path = dir // path_dir // path_f in
if contains_dot_dot full_path then ( if contains_dot_dot full_path then (
S.Response.fail ~code:403 "Path is forbidden"; S.Response.fail ~code:403 "Path is forbidden";
) else if not (Sys.file_exists full_path) then ( ) 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 ( ) else if Sys.is_directory full_path then (
S._debug (fun k->k "list dir %S (topdir %S)" full_path dir); S._debug (fun k->k "list dir %S (topdir %S)" full_path dir);
let body = let parent = Filename.(dirname path) in
html_list_dir ~top:dir path let parent = if parent <> path then Some parent else None in
~parent:(if same_path full_path dir then None else Some dir) let body = html_list_dir ~top:dir path ~parent in
in
S.Response.make ~headers:[header_html] (Ok body) S.Response.make ~headers:[header_html] (Ok body)
) else ( ) else (
try try