From 7f6881231243602a98756e253cf9f8e4d366a009 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Sun, 17 Nov 2019 17:15:52 -0600
Subject: [PATCH] feat: allow `delete` and use it in http_of_dir

---
 src/Tiny_httpd.ml      |  7 +++++-
 src/Tiny_httpd.mli     |  1 +
 src/bin/http_of_dir.ml | 49 +++++++++++++++++++++++++++++-------------
 3 files changed, 41 insertions(+), 16 deletions(-)

diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml
index f1a94628..e2123f51 100644
--- a/src/Tiny_httpd.ml
+++ b/src/Tiny_httpd.ml
@@ -46,6 +46,7 @@ module Meth = struct
     | `PUT
     | `POST
     | `HEAD
+    | `DELETE
   ]
 
   let to_string = function
@@ -53,6 +54,7 @@ module Meth = struct
     | `PUT -> "PUT"
     | `HEAD -> "HEAD"
     | `POST -> "POST"
+    | `DELETE -> "DELETE"
   let pp out s = Format.pp_print_string out (to_string s)
 
   let of_string = function
@@ -60,6 +62,7 @@ module Meth = struct
     | "PUT" -> `PUT
     | "POST" -> `POST
     | "HEAD" -> `HEAD
+    | "DELETE" -> `DELETE
     | s -> bad_reqf 400 "unknown method %S" s
 end
 
@@ -388,7 +391,9 @@ let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit =
             (fun resp cb -> match cb req resp with None -> resp | Some r' -> r')
             resp self.cb_encode_resp
         with
-        | Bad_req _ as e -> raise e
+        | Bad_req (code,s) ->
+          continue := false;
+          Response.make_raw ~code s
         | e ->
           Response.fail ~code:500 "server error: %s" (Printexc.to_string e)
       in
diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli
index 574d6c9d..1a00f5b0 100644
--- a/src/Tiny_httpd.mli
+++ b/src/Tiny_httpd.mli
@@ -5,6 +5,7 @@ module Meth : sig
     | `PUT
     | `POST
     | `HEAD
+    | `DELETE
   ]
 
   val pp : Format.formatter -> t -> unit
diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml
index 92a1e75e..800c67f7 100644
--- a/src/bin/http_of_dir.ml
+++ b/src/bin/http_of_dir.ml
@@ -7,11 +7,13 @@ type config = {
   mutable port: int;
   mutable upload: bool;
   mutable max_upload_size: int;
+  mutable delete: bool;
 }
 
 let default_config () : config = {
   addr="127.0.0.1";
   port=8080;
+  delete=false;
   upload=true;
   max_upload_size = 10 * 1024 * 1024;
 }
@@ -26,9 +28,10 @@ let contains_dot_dot s =
   with Exit -> true
 
 let header_html = "Content-Type", "text/html"
+let (//) = Filename.concat
 
-let html_list_dir ~parent d : string =
-  let entries = Sys.readdir d in
+let html_list_dir ~top ~parent d : string =
+  let entries = Sys.readdir @@ (top // d) in
   let body = Buffer.create 256 in
   Printf.bprintf body "<ul>\n";
   begin match parent with
@@ -38,10 +41,9 @@ let html_list_dir ~parent d : string =
   end;
   Array.iter
     (fun f ->
-       let full = Filename.concat d f in
-       if not @@ contains_dot_dot f then (
+       if not @@ contains_dot_dot (d // f) then (
          Printf.bprintf body "  <li> <a href=\"/%s\"> %s %s </a> </li>\n"
-           full (if Sys.is_directory full then "[dir]" else "") f;
+           (d // f) f (if Sys.is_directory (top // d // f) then "[dir]" else "");
        )
     )
     entries;
@@ -53,7 +55,20 @@ let same_path a 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
+  if config.delete then (
+    S.add_path_handler server ~meth:`DELETE "/%s"
+      (fun path _req ->
+         if contains_dot_dot path then (
+           S.Response.fail_raise ~code:403 "invalid path in delete"
+         );
+         S.Response.make
+           (try
+              Sys.remove (dir // path); Ok "file deleted successfully"
+            with e -> Error (500, Printexc.to_string e))
+      );
+  );
   if config.upload then (
     S.add_path_handler server ~meth:`PUT "/%s"
       ~accept:(fun req ->
@@ -68,7 +83,7 @@ let serve ~config (dir:string) : _ result =
                         string_of_int config.max_upload_size)
         )
       (fun path req ->
-         let fpath = Filename.concat dir path in
+         let fpath = dir // path in
          let oc =
            try open_out fpath
            with e ->
@@ -83,21 +98,23 @@ let serve ~config (dir:string) : _ result =
   );
   S.add_path_handler server ~meth:`GET "/%s"
     (fun path _req ->
-       let f = Filename.concat dir path in
-       if contains_dot_dot f then (
+       let path_dir = Filename.dirname path in
+       let path_f = Filename.basename path in
+       let full_path = dir // path_dir // path_f in
+       if contains_dot_dot full_path then (
          S.Response.fail ~code:403 "Path is forbidden";
-       ) else if not (Sys.file_exists f) then (
+       ) else if not (Sys.file_exists full_path) then (
          S.Response.fail ~code:404 "file not found";
-       ) else if Sys.is_directory f then (
-         S._debug (fun k->k "list dir %S (topdir %S)"  f dir);
+       ) 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 f
-             ~parent:(if same_path f dir then None else Some dir)
+           html_list_dir ~top:dir path
+             ~parent:(if same_path full_path dir then None else Some dir)
          in
          S.Response.make ~headers:[header_html] (Ok body)
        ) else (
          try
-           let ic = open_in path in
+           let ic = open_in full_path in
            S.Response.make_raw_chunked ~code:200 (input ic)
          with e ->
            S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)
@@ -118,7 +135,9 @@ let main () =
       "--max-upload", Int (fun i -> config.max_upload_size <- 1024 * 1024 * i),
       "maximum size of files that can be uploaded, in MB";
       "--debug", Unit (fun () -> S._enable_debug true), " debug mode";
-    ]) (fun _ -> raise (Arg.Bad "no positional arguments")) "http_of_dir [options]";
+      "--delete", Unit (fun () -> config.delete <- true), " enable `delete` on files";
+      "--no-delete", Unit (fun () -> config.delete <- false), " disable `delete` on files";
+    ]) (fun s -> dir_ := s) "http_of_dir [options] [dir]";
   match serve ~config !dir_ with
   | Ok () -> ()
   | Error e ->