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

factor code generation; fix bug in dir/

Browse source
This commit is contained in:
Simon Cruanes 2022-03-17 23:02:01 -04:00
parent d5c828978d
commit 8f32b67a03
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
2 changed files with 20 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/Tiny_httpd_dir.ml
View file

@ -242,7 +242,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS:VFS) as vfs) ~prefix server :
) else if VFS.is_directory path then ( ) else if VFS.is_directory path then (
S._debug (fun k->k "list dir %S (topdir %S)" path VFS.descr); S._debug (fun k->k "list dir %S (topdir %S)" path VFS.descr);
let parent = Filename.(dirname path) in let parent = Filename.(dirname path) in
let parent = if path <> "." then Some parent else None in let parent = if Filename.basename path <> "." then Some parent else None in
match config.dir_behavior with match config.dir_behavior with
| Index | Index_or_lists when VFS.contains (path // "index.html") -> | Index | Index_or_lists when VFS.contains (path // "index.html") ->
(* redirect using path, not full path *) (* redirect using path, not full path *)

35
src/gen/gentags.ml
View file

@ -333,7 +333,7 @@ type nary' = ?if_:bool -> attribute list -> (Out.t -> unit) -> elt
let (@<) (out:Out.t) (elt:elt) : unit = elt out let (@<) (out:Out.t) (elt:elt) : unit = elt out
(** Escape string so it can be safely embedded in HTML text. *) (** Escape string so it can be safely embedded in HTML text. *)
let str_escape (out:Out.t) (s:string) : unit = let _str_escape (out:Out.t) (s:string) : unit =
String.iter (function String.iter (function
| '<' -> Out.add_string out "&lt;" | '<' -> Out.add_string out "&lt;"
| '>' -> Out.add_string out "&gt;" | '>' -> Out.add_string out "&gt;"
@ -344,26 +344,34 @@ let str_escape (out:Out.t) (s:string) : unit =
s s
(** Print the value part of an attribute *) (** Print the value part of an attribute *)
let attr_escape (out:Out.t) (s:string) = let _attr_escape (out:Out.t) (s:string) =
Out.add_char out '"'; Out.add_char out '"';
str_escape out s; _str_escape out s;
Out.add_char out '"' Out.add_char out '"'
(** Output a list of attributes. *) (** Output a list of attributes. *)
let write_attrs (out:Out.t ) (l:attribute list) : unit = let _write_attrs (out:Out.t ) (l:attribute list) : unit =
List.iter List.iter
(fun (k,v) -> (fun (k,v) ->
Out.add_char out ' '; Out.add_char out ' ';
Out.add_string out k; Out.add_string out k;
Out.add_char out '='; Out.add_char out '=';
attr_escape out v) _attr_escape out v)
l l
(** Write a tag, with its attributes.
@param void if true, end with "/>", otherwise end with ">" *)
let _write_tag_attrs ~void (out:Out.t) (tag:string) (attrs:attribute list) : unit =
Out.add_string out "<";
Out.add_string out tag;
_write_attrs out attrs;
if void then Out.add_string out "/>" else Out.add_string out ">"
(** Emit a string value, which will be escaped. *) (** Emit a string value, which will be escaped. *)
let txt (txt:string) : elt = fun out -> str_escape out txt let txt (txt:string) : elt = fun out -> _str_escape out txt
(** Formatted version of {!txt} *) (** Formatted version of {!txt} *)
let txtf fmt = Format.kasprintf (fun s -> fun out -> str_escape out s) fmt let txtf fmt = Format.kasprintf (fun s -> fun out -> _str_escape out s) fmt
(** Emit raw HTML. Caution, this can lead to injection vulnerabilities, (** Emit raw HTML. Caution, this can lead to injection vulnerabilities,
never use with text that comes from untrusted users. *) never use with text that comes from untrusted users. *)
@ -388,9 +396,8 @@ let emit_void name =
name name; name name;
pf "let %s : void = fun ?(if_=true) attrs out ->\n" oname; pf "let %s : void = fun ?(if_=true) attrs out ->\n" oname;
pf " if if_ then (\n"; pf " if if_ then (\n";
pf " Out.add_string out \"<%s\";\n" name; pf " _write_tag_attrs ~void:true out %S attrs;\n" name;
pf " write_attrs out attrs;\n"; pf " )";
pf " Out.add_string out \"/>\")";
pf "\n\n"; pf "\n\n";
() ()
@ -403,9 +410,7 @@ let emit_normal name =
pf " if if_ then (\n"; pf " if if_ then (\n";
(* for <pre>, newlines actually matter *) (* for <pre>, newlines actually matter *)
if name="pre" then pf " Out.with_no_format_nl out @@ fun () ->\n"; if name="pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
pf " Out.add_string out \"<%s\";\n" name; pf " _write_tag_attrs ~void:false out %S attrs;\n" name;
pf " write_attrs out attrs;\n";
pf " Out.add_string out \">\";\n";
pf " Out.add_format_nl out;\n"; pf " Out.add_format_nl out;\n";
pf " List.iter (fun sub -> sub out; Out.add_format_nl out) sub;\n"; pf " List.iter (fun sub -> sub out; Out.add_format_nl out) sub;\n";
pf " Out.add_string out \"</%s>\";" name; pf " Out.add_string out \"</%s>\";" name;
@ -419,9 +424,7 @@ let emit_normal name =
pf "let %s : nary' = fun ?(if_=true) attrs f out ->\n" oname; pf "let %s : nary' = fun ?(if_=true) attrs f out ->\n" oname;
pf " if if_ then (\n"; pf " if if_ then (\n";
if name="pre" then pf " Out.with_no_format_nl out @@ fun () ->\n"; if name="pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
pf " Out.add_string out \"<%s\";\n" name; pf " _write_tag_attrs ~void:false out %S attrs;\n" name;
pf " write_attrs out attrs;\n";
pf " Out.add_string out \">\";\n";
pf " Out.add_format_nl out;\n"; pf " Out.add_format_nl out;\n";
pf " f out;\n"; pf " f out;\n";
pf " Out.add_string out \"</%s>\";" name; pf " Out.add_string out \"</%s>\";" name;