diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml
index a86f0404..c250e9cb 100644
--- a/src/Tiny_httpd_dir.ml
+++ b/src/Tiny_httpd_dir.ml
@@ -59,15 +59,54 @@ let _decode_path s = match U.percent_decode s with Some s->s | None -> s
let is_hidden s = String.length s>0 && s.[0] = '.'
-let html_list_dir ~top ~parent d : string =
- let entries = Sys.readdir @@ (top // d) in
+module type VFS = sig
+ val descr : string
+ val is_directory : string -> bool
+ val contains : string -> bool
+ val list_dir : string -> string array
+ val delete : string -> unit
+ val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
+ val read_file_content : string -> Tiny_httpd.Byte_stream.t
+ val file_size : string -> int option
+ val file_mtime : string -> float option
+end
+
+type vfs = (module VFS)
+
+let vfs_of_dir (top:string) : vfs =
+ let module M = struct
+ let descr = top
+ let (//) = Filename.concat
+ let is_directory f = Sys.is_directory (top // f)
+ let contains f = Sys.file_exists (top // f)
+ let list_dir f = Sys.readdir (top // f)
+ let read_file_content f =
+ let ic = open_in_bin (top // f) in
+ S.Byte_stream.of_chan ic
+ let create f =
+ let oc = open_out_bin (top // f) in
+ let write = output oc in
+ let close() = close_out oc in
+ write, close
+ let delete f = Sys.remove (top // f)
+ let file_size f =
+ try Some (Unix.stat (top // f)).Unix.st_size
+ with _ -> None
+ let file_mtime f =
+ try Some (Unix.stat (top // f)).Unix.st_mtime
+ with _ -> None
+ end in
+ (module M)
+
+let html_list_dir (module VFS:VFS) ~parent d : string =
+ let entries = VFS.list_dir d in
Array.sort compare entries;
let body = Buffer.create 256 in
(* TODO: breadcrumbs for the path, each element a link to the given ancestor dir *)
Printf.bprintf body {| http_of_dir %S
Index of %S
- |} top d;
+ |} VFS.descr d;
begin match parent with
| None -> ()
| Some p ->
@@ -88,16 +127,17 @@ let html_list_dir ~top ~parent d : string =
Printf.bprintf body "\n";
);
if not @@ contains_dot_dot (d // f) then (
- let fpath = top // d // f in
- if not @@ Sys.file_exists fpath then (
+ let fpath = d // f in
+ if not @@ VFS.contains fpath then (
Printf.bprintf body " %s [invalid file]\n" f
) else (
let size =
- try Printf.sprintf " (%s)" @@ human_size (Unix.stat fpath).Unix.st_size
- with _ -> ""
+ match VFS.file_size fpath with
+ | Some f -> Printf.sprintf " (%s)" @@ human_size f
+ | None -> ""
in
Printf.bprintf body " %s %s%s \n"
- (encode_path (d // f)) f (if Sys.is_directory fpath then "[dir]" else "") size
+ (encode_path (d // f)) f (if VFS.is_directory fpath then "[dir]" else "") size
);
)
)
@@ -114,7 +154,8 @@ let finally_ ~h x f =
h x;
raise e
-let add_dir_path ~config ~dir ~prefix server =
+(* @param on_fs: if true, we assume the file exists on the FS *)
+let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS:VFS) as vfs) ~prefix server : unit=
if config.delete then (
S.add_route_handler server ~meth:`DELETE
@@ -125,7 +166,7 @@ let add_dir_path ~config ~dir ~prefix server =
) else (
S.Response.make_string
(try
- Sys.remove (dir // path); Ok "file deleted successfully"
+ VFS.delete path; Ok "file deleted successfully"
with e -> Error (500, Printexc.to_string e))
)
);
@@ -147,17 +188,15 @@ let add_dir_path ~config ~dir ~prefix server =
| _ -> Ok ()
)
(fun path req ->
- let fpath = dir // path in
- let oc =
- try open_out fpath
+ let write, close =
+ try VFS.create path
with e ->
S.Response.fail_raise ~code:403 "cannot upload to %S: %s"
path (Printexc.to_string e)
in
let req = S.Request.limit_body_size ~max_size:config.max_upload_size req in
- S.Byte_stream.to_chan oc req.S.Request.body;
- flush oc;
- close_out oc;
+ S.Byte_stream.iter write req.S.Request.body;
+ close ();
S._debug (fun k->k "done uploading");
S.Response.make_raw ~code:201 "upload successful"
)
@@ -171,32 +210,31 @@ let add_dir_path ~config ~dir ~prefix server =
S.add_route_handler server ~meth:`GET
S.Route.(exact_path prefix (rest_of_path_urlencoded))
(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"
+ match VFS.file_mtime path with
+ | None -> S.Response.fail_raise ~code:403 "Cannot access file"
+ | Some t -> Printf.sprintf "mtime: %.4f" t
) in
- if contains_dot_dot full_path then (
+ if contains_dot_dot path then (
S.Response.fail ~code:403 "Path is forbidden";
- ) else if not (Sys.file_exists full_path) then (
+ ) else if not (VFS.contains 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);
+ ) else if VFS.is_directory path then (
+ S._debug (fun k->k "list dir %S (topdir %S)" path VFS.descr);
let parent = Filename.(dirname path) in
let parent = if parent <> path then Some parent else None in
match config.dir_behavior with
- | Index | Index_or_lists when
- Sys.file_exists (full_path // "index.html") ->
+ | Index | Index_or_lists when VFS.contains (path // "index.html") ->
(* redirect using path, not full path *)
let new_path = "/" // path // "index.html" in
S._debug (fun k->k "redirect to `%s`" new_path);
S.Response.make_raw ~code:301 ""
~headers:S.Headers.(empty |> set "location" new_path)
| Lists | Index_or_lists ->
- let body = html_list_dir ~top:dir path ~parent in
+ let body = html_list_dir vfs path ~parent in
S.Response.make_string
~headers:[header_html; "ETag", Lazy.force mtime]
(Ok body)
@@ -204,23 +242,26 @@ let add_dir_path ~config ~dir ~prefix server =
S.Response.make_raw ~code:405 "listing dir not allowed"
) else (
try
- let ic = open_in full_path in
let mime_type =
- if Filename.extension full_path = ".css" then (
+ if Filename.extension path = ".css" then (
["Content-Type", "text/css"]
- ) else if Filename.extension full_path = ".js" then (
+ ) else if Filename.extension path = ".js" then (
["Content-Type", "text/javascript"]
- ) else try
- let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" full_path) in
+ ) else if on_fs then (
+ (* call "file" util *)
+ try
+ let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" (top // path)) in
finally_ ~h:(fun p->ignore @@ Unix.close_process_in p) p
(fun p ->
try ["Content-Type", String.trim (input_line p)]
with _ -> [])
with _ -> []
+ ) else []
in
+ let stream = VFS.read_file_content path in
S.Response.make_raw_stream
~headers:(mime_type@["Etag", Lazy.force mtime])
- ~code:200 (S.Byte_stream.of_chan ic)
+ ~code:200 stream
with e ->
S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e))
)
@@ -229,3 +270,10 @@ let add_dir_path ~config ~dir ~prefix server =
S.Route.(exact_path prefix (string @/ return))
(fun _ _ -> S.Response.make_raw ~code:405 "download not allowed");
);
+ ()
+
+let add_vfs ~config ~vfs ~prefix server : unit =
+ add_vfs_ ~on_fs:false ~top:"." ~config ~prefix ~vfs server
+
+let add_dir_path ~config ~dir ~prefix server : unit =
+ add_vfs_ ~on_fs:true ~top:dir ~config ~prefix ~vfs:(vfs_of_dir dir) server
diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli
index 4e5cdf77..183d363c 100644
--- a/src/Tiny_httpd_dir.mli
+++ b/src/Tiny_httpd_dir.mli
@@ -78,3 +78,55 @@ val add_dir_path :
dir:string ->
prefix:string ->
Tiny_httpd.t -> unit
+
+(** Virtual file system.
+
+ This is used to emulate a file system from pure OCaml functions and data,
+ e.g. for resources bundled inside the web server.
+ @since NEXT_RELEASE
+*)
+module type VFS = sig
+ val descr : string
+ (** Description of the VFS *)
+
+ val is_directory : string -> bool
+
+ val contains : string -> bool
+ (** [file_exists vfs path] returns [true] if [path] points to a file
+ or directory inside [vfs]. *)
+
+ val list_dir : string -> string array
+ (** List directory. This only returns basenames, the files need
+ to be put in the directory path using {!Filename.concat}. *)
+
+ val delete : string -> unit
+ (** Delete path *)
+
+ val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
+ (** Create a file and obtain a pair [write, close] *)
+
+ val read_file_content : string -> Tiny_httpd.Byte_stream.t
+ (** Read content of a file *)
+
+ val file_size : string -> int option
+ (** File size, e.g. using "stat" *)
+
+ val file_mtime : string -> float option
+ (** File modification time, e.g. using "stat" *)
+end
+
+val vfs_of_dir : string -> (module VFS)
+(** [vfs_of_dir dir] makes a virtual file system that reads from the
+ disk.
+ @since NEXT_RELEASE
+*)
+
+val add_vfs :
+ config:config ->
+ vfs:(module VFS) ->
+ prefix:string ->
+ Tiny_httpd.t -> unit
+(** Similar to {!add_dir_path} but using a virtual file system instead.
+ @since NEXT_RELEASE
+*)
+