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";
+ begin match parent with
+ | None -> ()
+ | Some p ->
+ Printf.bprintf body " - (parent directory)
\n" p;
+ end;
+ Array.iter
+ (fun f ->
+ let full = Filename.concat d f in
+ if not @@ contains_dot_dot f then (
+ Printf.bprintf body " - %s %s
\n"
+ full (if Sys.is_directory full then "[dir]" else "") f;
+ )
+ )
+ entries;
+ 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 ()