diff --git a/http_of_dir.sh b/http_of_dir.sh new file mode 100755 index 00000000..f9ba2a7b --- /dev/null +++ b/http_of_dir.sh @@ -0,0 +1,2 @@ +#!/bin/sh +exec dune exec ./src/bin/http_of_dir.exe -- $@ diff --git a/src/bin/dune b/src/bin/dune new file mode 100644 index 00000000..2a501f90 --- /dev/null +++ b/src/bin/dune @@ -0,0 +1,6 @@ + +(executable + (name http_of_dir) + (public_name http_of_dir) + (flags :standard -warn-error -3) + (libraries simplehttpserver str)) diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml new file mode 100644 index 00000000..9b4e6a9a --- /dev/null +++ b/src/bin/http_of_dir.ml @@ -0,0 +1,80 @@ + +module S = SimpleHTTPServer +module Pf = Printf + +let contains_dot_dot s = + try + String.iteri + (fun i c -> + if c='.' && i+1 < String.length s && String.get s (i+1) = '.' then raise Exit) + s; + false + with Exit -> true + +let header_html = "Content-Type", "text/html" + +let html_list_dir ~parent d : string = + let entries = Sys.readdir d in + let body = Buffer.create 256 in + Printf.bprintf body "\n"; + Buffer.contents body + +let serve ~addr ~port (dir:string) : _ result = + let server = S.create ~addr ~port () in + S.add_path_handler server ~meth:`GET "/" + (fun _req () -> + let body = html_list_dir ~parent:None dir in + S.Response.make ~headers:[header_html] (Ok body) + ); + S.add_path_handler server ~meth:`GET "/file/%s" + (fun _req path () -> + let f = Filename.concat dir path in + if contains_dot_dot f then ( + S.Response.fail ~code:503 "Path is forbidden"; + ) else if Sys.is_directory f then ( + let body = html_list_dir ~parent:(Some dir) f in + S.Response.make ~headers:[header_html] (Ok body) + ) else ( + try + (* TODO: serve chunks *) + let _ic = open_in path in + + assert false + with e -> + S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e) + )); + S.run server + + +let main () = + let addr_ = ref "127.0.0.1" in + let port_ = ref 8080 in + let dir_ = ref "." in + Arg.parse (Arg.align [ + "--addr", Set_string addr_, " address to listen on"; + "-a", Set_string addr_, " alias to --listen"; + "--port", Set_int port_, " port to listen on"; + "-p", Set_int port_, " alias to --port"; + "--dir", Set_string dir_, " directory to serve (default: \".\")"; + ]) (fun _ -> raise (Arg.Bad "no positional arguments")) "http_of_dir [options]"; + match serve ~addr:!addr_ ~port:!port_ !dir_ with + | Ok () -> () + | Error e -> + raise e + +let () = main ()