wip: simple binary for serving a directory

http_of_dir.sh

@@ -0,0 +1,2 @@
+#!/bin/sh
+exec dune exec ./src/bin/http_of_dir.exe -- $@

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))

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