diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index e2123f51..f20d91ee 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -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 ); diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index 800c67f7..7f9819f2 100644 --- a/src/bin/http_of_dir.ml +++ b/src/bin/http_of_dir.ml @@ -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 "\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