feat(http_of_dir): basic cache control with mtime in etag

src/Tiny_httpd.ml

@@ -179,6 +179,7 @@ module Response_code = struct
     | 300 -> "Multiple choices"
     | 301 -> "Moved permanently"
     | 302 -> "Found"
+    | 304 -> "Not Modified"
     | 400 -> "Bad request"
     | 403 -> "Forbidden"
     | 404 -> "Not found"

src/bin/http_of_dir.ml

@@ -39,7 +39,7 @@ let html_list_dir ~top ~parent d : string =
   |} top d;
   begin match parent with
     | None -> ()
-    | Some p -> 
+    | Some p ->
       Printf.bprintf body "<a href=\"/%s\"> (parent directory) </a>\n" p;
   end;
   Printf.bprintf body "<ul>\n";
@@ -54,7 +54,16 @@ let html_list_dir ~top ~parent d : string =
   Printf.bprintf body "</ul></body>\n";
   Buffer.contents body
 
-let serve ~config (dir:string) : _ result = 
+(* 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 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 (
@@ -103,22 +112,33 @@ let serve ~config (dir:string) : _ result =
       (fun _ _  -> S.Response.make_raw ~code:405 "upload not allowed");
   );
   S.add_path_handler server ~meth:`GET "/%s"
-    (fun path _req ->
+    (fun path req ->
        let full_path = dir // path in
+       let mtime = lazy (
+         try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime
+         with _ -> S.Response.fail_raise ~code:403 "Cannot access file"
+       ) in
        if contains_dot_dot full_path then (
          S.Response.fail ~code:403 "Path is forbidden";
        ) else if not (Sys.file_exists full_path) then (
          S.Response.fail ~code:404 "File not found";
+       ) 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.Response.make_raw ~code:304 ""
        ) else if Sys.is_directory full_path then (
          S._debug (fun k->k "list dir %S (topdir %S)"  full_path dir);
          let parent = Filename.(dirname path) in
          let parent = if parent <> path then Some parent else None in
          let body = html_list_dir ~top:dir path ~parent in
-         S.Response.make_string ~headers:[header_html] (Ok body)
+         S.Response.make_string
+           ~headers:[header_html; "ETag", Lazy.force mtime]
+           (Ok body)
        ) else (
          try
            let ic = open_in full_path in
-           S.Response.make_raw_stream ~code:200 (S.Stream_.of_chan ic)
+           S.Response.make_raw_stream
+             ~headers:["Etag", Lazy.force mtime]
+             ~code:200 (S.Stream_.of_chan ic)
          with e ->
            S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)
        ));