mirror of
https://github.com/c-cube/tiny_httpd.git
synced 2025-12-06 11:15:35 -05:00
feat: add Tiny_httpd_dir.VFS to emulate file systems
the idea is to be able to serve static content from anything that looks like a file system, not just a directory. That could be a sqlite table, or a OCaml file with embedded content, etc.
This commit is contained in:
Simon Cruanes
parent
cdd7df29ac
commit
0078d91672
2 changed files with 132 additions and 32 deletions
|
|
@ -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 {|<head><title> http_of_dir %S</title><meta charset="utf-8">
|
||||
</head><body>
|
||||
<h2> Index of %S</h2>
|
||||
|} 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 "</details/>\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 " <li> %s [invalid file]</li>\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 " <li> <a href=\"/%s\"> %s </a> %s%s </li>\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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
*)
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue