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

fix(html): ensure that <pre> is printed without spurious newlines

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

49
src/gen/gentags.ml
View file

@ -291,11 +291,25 @@ module Out : sig
val clear : t -> unit
val add_char : t -> char -> unit
val add_string : t -> string -> unit
val add_format_nl : t -> unit
val with_no_format_nl : t -> (unit -> 'a) -> 'a
val to_string : t -> string
end = struct
include Buffer
let create () = Buffer.create 256
let to_string = contents
type t = {
buf: Buffer.t;
mutable fmt_nl: bool; (* if true, we print \b around to format the html *)
}
let create () = {buf=Buffer.create 256; fmt_nl=true}
let clear self = Buffer.clear self.buf; self.fmt_nl <- true
let[@inline] add_char self c = Buffer.add_char self.buf c
let[@inline] add_string self s = Buffer.add_string self.buf s
let to_string self = Buffer.contents self.buf
let add_format_nl self = if self.fmt_nl then add_char self '\n'
let with_no_format_nl self f =
if self.fmt_nl then (
self.fmt_nl <- false;
try let x=f() in self.fmt_nl <- true; x with e -> self.fmt_nl <- true; raise e
) else f()
end
type attribute = string * string
@ -316,6 +330,8 @@ type nary' = ?if_:bool -> attribute list -> (Out.t -> unit) -> elt
(** Element with children, represented as a continuation.
@param if_ if false, do not print anything (default true) *)
let (@<) (out:Out.t) (elt:elt) : unit = elt out
(** Escape string so it can be safely embedded in HTML text. *)
let str_escape (out:Out.t) (s:string) : unit =
String.iter (function
@ -346,6 +362,9 @@ let write_attrs (out:Out.t ) (l:attribute list) : unit =
(** Emit a string value, which will be escaped. *)
let txt (txt:string) : elt = fun out -> str_escape out txt
(** Formatted version of {!txt} *)
let txtf fmt = Format.kasprintf (fun s -> fun out -> str_escape out s) fmt
(** Emit raw HTML. Caution, this can lead to injection vulnerabilities,
never use with text that comes from untrusted users. *)
let raw_html (s:string) : elt = fun out -> Out.add_string out s
@ -382,11 +401,15 @@ let emit_normal name =
name name;
pf "let %s : nary = fun ?(if_=true) attrs sub out ->\n" oname;
pf " if if_ then (\n";
(* for <pre>, newlines actually matter *)
if name="pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
pf " Out.add_string out \"<%s\";\n" name;
pf " write_attrs out attrs;\n";
pf " Out.add_string out \">\\n\";\n";
pf " List.iter (fun sub -> sub out; Out.add_char out '\\n') sub;\n";
pf " Out.add_string out \"</%s>\\n\")" name;
pf " Out.add_string out \">\";\n";
pf " Out.add_format_nl out;\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_format_nl out)\n";
pf "\n\n";
(* block version *)
@ -395,16 +418,24 @@ let emit_normal name =
name name;
pf "let %s : nary' = fun ?(if_=true) attrs f out ->\n" oname;
pf " if if_ then (\n";
if name="pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
pf " Out.add_string out \"<%s\";\n" name;
pf " write_attrs out attrs;\n";
pf " Out.add_string out \">\\n\";\n";
pf " Out.add_string out \">\";\n";
pf " Out.add_format_nl out;\n";
pf " f out;\n";
pf " Out.add_string out \"</%s>\\n\")" name;
pf " Out.add_string out \"</%s>\";" name;
pf " Out.add_format_nl out)\n";
pf "\n\n";
()
let doc_attrs = {|Attributes.
This module contains combinator for the standard attributes.
One can also just use a pair of strings. |}
let emit_attr name =
let oname = oname name in
pf " (** Attribute %S. *)\n" name;
@ -415,7 +446,7 @@ let () =
pf "%s\n" prelude;
List.iter emit_void void;
List.iter emit_normal normal;
pf "(** Attributes *)\n";
pf "(** %s *)\n" doc_attrs;
pf "module A = struct\n";
pf " type t = string -> attribute\n";
pf " (** Attribute builder *)\n";