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

code cleanup

Browse source
This commit is contained in:
Simon Cruanes 2021-12-20 09:53:19 -05:00
parent bfee36572c
commit bf2bf6832d
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
2 changed files with 73 additions and 82 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

153
src/Tiny_httpd_dir.ml
View file

@ -3,7 +3,7 @@ module U = Tiny_httpd_util
module Pf = Printf module Pf = Printf
type dir_behavior = type dir_behavior =
Index | Lists | IndexAndLists | Forbidden | Index | Lists | Index_or_lists | Forbidden
type config = { type config = {
mutable download: bool; mutable download: bool;
@ -25,7 +25,7 @@ let contains_dot_dot s =
try try
String.iteri String.iteri
(fun i c -> (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; s;
false false
with Exit -> true with Exit -> true
@ -100,29 +100,20 @@ let finally_ ~h x f =
h x; h x;
raise e 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 = let add_dir_path ~config ~dir ~prefix server =
if config.delete then ( if config.delete then (
S.add_route_handler server ~meth:`DELETE S.add_route_handler server ~meth:`DELETE
S.Route.(exact_path prefix (rest_of_path_urlencoded)) S.Route.(exact_path prefix (rest_of_path_urlencoded))
(fun path _req -> (fun path _req ->
if contains_dot_dot path then ( if contains_dot_dot path then (
S.Response.fail_raise ~code:403 "invalid path in delete" S.Response.fail_raise ~code:403 "invalid path in delete"
) else ( ) else (
S.Response.make_string S.Response.make_string
(try (try
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 ( ) else (
S.add_route_handler server ~meth:`DELETE 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.add_route_handler_stream server ~meth:`PUT
S.Route.(exact_path prefix (rest_of_path_urlencoded)) S.Route.(exact_path prefix (rest_of_path_urlencoded))
~accept:(fun req -> ~accept:(fun req ->
match S.Request.get_header_int req "Content-Length" with match S.Request.get_header_int req "Content-Length" with
| Some n when n > config.max_upload_size -> | Some n when n > config.max_upload_size ->
Error (403, "max upload size is " ^ string_of_int 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 -> | Some _ when contains_dot_dot req.S.Request.path ->
Error (403, "invalid path (contains '..')") Error (403, "invalid path (contains '..')")
| _ -> Ok () | _ -> Ok ()
) )
(fun path req -> (fun path req ->
let fpath = dir // path in let fpath = dir // path in
let oc = let oc =
try open_out fpath try open_out fpath
with e -> with e ->
S.Response.fail_raise ~code:403 "cannot upload to %S: %s" S.Response.fail_raise ~code:403 "cannot upload to %S: %s"
path (Printexc.to_string e) path (Printexc.to_string e)
in in
let req = S.Request.limit_body_size ~max_size:config.max_upload_size req 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; S.Byte_stream.to_chan oc req.S.Request.body;
flush oc; flush oc;
close_out oc; close_out oc;
S._debug (fun k->k "done uploading"); S._debug (fun k->k "done uploading");
S.Response.make_raw ~code:201 "upload successful" S.Response.make_raw ~code:201 "upload successful"
) )
) else ( ) else (
S.add_route_handler server ~meth:`PUT S.add_route_handler server ~meth:`PUT
S.Route.(exact_path prefix (string @/ return)) 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 ( if config.download then (
S.add_route_handler server ~meth:`GET S.add_route_handler server ~meth:`GET
S.Route.(exact_path prefix (rest_of_path_urlencoded)) S.Route.(exact_path prefix (rest_of_path_urlencoded))
(fun path req -> (fun path req ->
let full_path = dir // path in let full_path = dir // path in
let mtime = lazy ( let mtime = lazy (
try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime
with _ -> S.Response.fail_raise ~code:403 "Cannot access file" with _ -> S.Response.fail_raise ~code:403 "Cannot access file"
) in ) 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 S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime) then ( ) 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._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime));
S.Response.make_raw ~code:304 "" S.Response.make_raw ~code:304 ""
) 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 parent = Filename.(dirname path) in let parent = Filename.(dirname path) in
let parent = if parent <> path then Some parent else None in let parent = if parent <> path then Some parent else None in
match config.dir_behavior with match config.dir_behavior with
| Index | IndexAndLists when | Index | Index_or_lists when
Sys.file_exists (full_path // "index.html") -> Sys.file_exists (full_path // "index.html") ->
(* redirect using path, not full path *) (* redirect using path, not full path *)
let new_path = "/" // path // "index.html" in let new_path = "/" // path // "index.html" in
S._debug (fun k->k "redirect to `%s`" new_path); S._debug (fun k->k "redirect to `%s`" new_path);
S.Response.make_raw ~code:301 "" S.Response.make_raw ~code:301 ""
~headers:S.Headers.(empty |> set "location" new_path) ~headers:S.Headers.(empty |> set "location" new_path)
| Lists | IndexAndLists -> | Lists | Index_or_lists ->
let body = html_list_dir ~top:dir path ~parent in let body = html_list_dir ~top:dir path ~parent in
S.Response.make_string S.Response.make_string
~headers:[header_html; "ETag", Lazy.force mtime] ~headers:[header_html; "ETag", Lazy.force mtime]
(Ok body) (Ok body)
| Forbidden | Index -> | Forbidden | Index ->
S.Response.make_raw ~code:405 "listing dir not allowed" S.Response.make_raw ~code:405 "listing dir not allowed"
) else ( ) else (
try try
let ic = open_in full_path in let ic = open_in full_path in
let mime_type = let mime_type =
if Filename.extension full_path = ".css" then ( if Filename.extension full_path = ".css" then (
["Content-Type", "text/css"] ["Content-Type", "text/css"]
) else if Filename.extension full_path = ".js" then ( ) else if Filename.extension full_path = ".js" then (
["Content-Type", "text/javascript"] ["Content-Type", "text/javascript"]
) else try ) else try
let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" full_path) in 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 finally_ ~h:(fun p->ignore @@ Unix.close_process_in p) p
(fun p -> (fun p ->
try ["Content-Type", String.trim (input_line p)] try ["Content-Type", String.trim (input_line p)]
with _ -> []) with _ -> [])
with _ -> [] with _ -> []
in in
S.Response.make_raw_stream S.Response.make_raw_stream
~headers:(mime_type@["Etag", Lazy.force mtime]) ~headers:(mime_type@["Etag", Lazy.force mtime])
~code:200 (S.Byte_stream.of_chan ic) ~code:200 (S.Byte_stream.of_chan ic)
with e -> 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))
) )
) else ( ) else (
S.add_route_handler server ~meth:`GET S.add_route_handler server ~meth:`GET
S.Route.(exact_path prefix (string @/ return)) 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");
); );

2
src/bin/http_of_dir.ml
View file

@ -42,7 +42,7 @@ let main () =
" automatically redirect to index.html if present"; " automatically redirect to index.html if present";
"--list-dir", Unit (fun () -> config.dir_behavior <- Lists), "--list-dir", Unit (fun () -> config.dir_behavior <- Lists),
" automatically lists directory"; " 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"; " automatically redirect to index.html or lists directory";
"--delete", Unit (fun () -> config.delete <- true), " enable `delete` on files"; "--delete", Unit (fun () -> config.delete <- true), " enable `delete` on files";
"--no-delete", Unit (fun () -> config.delete <- false), " disable `delete` on files"; "--no-delete", Unit (fun () -> config.delete <- false), " disable `delete` on files";