simon/tiny_httpd
1
0
Fork 0
mirror of https://github.com/c-cube/tiny_httpd.git synced 2025-12-06 11:15:35 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

refactor(dir): use Html module to list directory content

Browse source
This commit is contained in:
Simon Cruanes 2022-03-17 22:34:10 -04:00
parent 6cf05bc733
commit efb653a2d6
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
1 changed files with 56 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

96
src/Tiny_httpd_dir.ml
View file

@ -1,5 +1,6 @@
module S = Tiny_httpd_server module S = Tiny_httpd_server
module U = Tiny_httpd_util module U = Tiny_httpd_util
module Html = Tiny_httpd_html
module Pf = Printf module Pf = Printf
type dir_behavior = type dir_behavior =
@ -98,53 +99,68 @@ let vfs_of_dir (top:string) : vfs =
end in end in
(module M) (module M)
let html_list_dir (module VFS:VFS) ~prefix ~parent d : string = let html_list_dir (module VFS:VFS) ~prefix ~parent d : Html.elt =
let entries = VFS.list_dir d in let entries = VFS.list_dir d in
Array.sort compare entries; Array.sort String.compare entries;
let body = Buffer.create 256 in let open Html in
html'[] @@ fun out ->
(* TODO: breadcrumbs for the path, each element a link to the given ancestor dir *) (* TODO: breadcrumbs for the path, each element a link to the given ancestor dir *)
Printf.bprintf body {|<head><title> list directory %S</title><meta charset="utf-8"> out @< head[][
</head><body> title[][txtf "list directory %S" VFS.descr];
<h2> Index of %S</h2> meta[A.charset "utf-8"];
|} VFS.descr d; ];
out @< body'[] @@ fun out ->
out @< h2[][txtf "Index of %S" d];
begin match parent with begin match parent with
| None -> () | None -> ()
| Some p -> | Some p ->
Printf.bprintf body "<a href=\"/%s\"> (parent directory) </a>\n" out @< a[A.href (encode_path (prefix // p))][txt"(parent directory)"];
(encode_path (prefix // p));
end; end;
Printf.bprintf body "<ul>\n";
let hidden_stop = ref 0 in out @< ul'[] @@ fun out ->
Array.iteri
(fun i f -> let n_hidden = ref 0 in
if is_hidden f && (i=0 || not (is_hidden entries.(i-1))) then ( Array.iter (fun f -> if is_hidden f then incr n_hidden) entries;
hidden_stop := i;
while !hidden_stop < Array.length entries && is_hidden entries.(!hidden_stop) do let emit_file f out : unit =
incr hidden_stop; if not @@ contains_dot_dot (d // f) then (
done; let fpath = d // f in
Printf.bprintf body "<details> <summary>(%d hidden files)</summary>\n" (!hidden_stop-i); if not @@ VFS.contains fpath then (
) else if i = !hidden_stop then ( out @< li[][txtf "%s [invalid file]" f];
Printf.bprintf body "</details/>\n"; ) else (
); let size =
if not @@ contains_dot_dot (d // f) then ( match VFS.file_size fpath with
let fpath = d // f in | Some f -> Printf.sprintf " (%s)" @@ human_size f
if not @@ VFS.contains fpath then ( | None -> ""
Printf.bprintf body " <li> %s [invalid file]</li>\n" f in
) else ( out @< li'[] @@ fun out ->
let size = out @< a[A.href ("/" // prefix // fpath)][txt f];
match VFS.file_size fpath with if VFS.is_directory fpath then out @< txt"[dir]";
| Some f -> Printf.sprintf " (%s)" @@ human_size f out @< txt size;
| None -> "" );
in
Printf.bprintf body " <li> <a href=\"/%s\"> %s </a> %s%s </li>\n"
(encode_path (prefix // fpath)) f
(if VFS.is_directory fpath then "[dir]" else "") size
);
)
) )
in
if !n_hidden>0 then (
out @< details'[] @@ fun out ->
out @< summary[][txtf "(%d hidden files)" !n_hidden];
Array.iter
(fun f ->
if is_hidden f then (
emit_file f out;
))
entries;
);
Array.iter
(fun f ->
if not @@ is_hidden f then emit_file f out)
entries; entries;
Printf.bprintf body "</ul></body>\n"; ()
Buffer.contents body
let finally_ ~h x f = let finally_ ~h x f =
try try
@ -235,7 +251,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS:VFS) as vfs) ~prefix server :
S.Response.make_raw ~code:301 "" S.Response.make_raw ~code:301 ""
~headers:S.Headers.(empty |> set "location" new_path) ~headers:S.Headers.(empty |> set "location" new_path)
| Lists | Index_or_lists -> | Lists | Index_or_lists ->
let body = html_list_dir ~prefix vfs path ~parent in let body = html_list_dir ~prefix vfs path ~parent |> Html.to_string_top in
S.Response.make_string S.Response.make_string
~headers:[header_html; "ETag", Lazy.force mtime] ~headers:[header_html; "ETag", Lazy.force mtime]
(Ok body) (Ok body)