mirror of
https://github.com/c-cube/tiny_httpd.git
synced 2025-12-05 19:00:32 -05:00
add a HTML module, with codegen to produce the combinators.
This commit is contained in:
Simon Cruanes
parent
533a42a661
commit
b387aa731d
5 changed files with 418 additions and 0 deletions
|
|
@ -1,4 +1,12 @@
|
|||
|
||||
(** Tiny Httpd.
|
||||
|
||||
A small HTTP/1.1 server, in pure OCaml, along with some utilities
|
||||
to build small websites. The primary use case is to build UIs for tools
|
||||
that are {b not} primarily websites, but can benefit from an embedded
|
||||
web server.
|
||||
*)
|
||||
|
||||
module Buf = Tiny_httpd_buf
|
||||
|
||||
module Byte_stream = Tiny_httpd_stream
|
||||
|
|
@ -8,3 +16,5 @@ include Tiny_httpd_server
|
|||
module Util = Tiny_httpd_util
|
||||
|
||||
module Dir = Tiny_httpd_dir
|
||||
|
||||
module Html = Tiny_httpd_html
|
||||
|
|
|
|||
19
src/Tiny_httpd_html.ml
Normal file
19
src/Tiny_httpd_html.ml
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
|
||||
(** @inline *)
|
||||
include Tiny_httpd_html_
|
||||
|
||||
(** Convert a HTML element to a string.
|
||||
@param top if true, add DOCTYPE at the beginning. The top element should then
|
||||
be a "html" tag. *)
|
||||
let to_string ?(top=false) (self:elt) : string =
|
||||
let buf = Buffer.create 256 in
|
||||
if top then Printf.bprintf buf "<!DOCTYPE html>\n";
|
||||
self buf;
|
||||
Buffer.contents buf
|
||||
|
||||
let to_string_top = to_string ~top:true
|
||||
|
||||
(** Convert a HTML element to a stream. This might just convert
|
||||
it to a string first, do not assume it to be more efficient. *)
|
||||
let to_stream (self:elt) : Tiny_httpd_stream.t =
|
||||
Tiny_httpd_stream.of_string @@ to_string self
|
||||
5
src/dune
5
src/dune
|
|
@ -5,3 +5,8 @@
|
|||
(libraries threads)
|
||||
(flags :standard -safe-string -warn-error -a+8)
|
||||
(wrapped false))
|
||||
|
||||
(rule
|
||||
(targets Tiny_httpd_html_.ml)
|
||||
(deps (:bin ./gen/gentags.exe))
|
||||
(action (with-stdout-to %{targets} (run %{bin}))))
|
||||
|
|
|
|||
4
src/gen/dune
Normal file
4
src/gen/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(executable
|
||||
(name gentags))
|
||||
|
||||
|
||||
380
src/gen/gentags.ml
Normal file
380
src/gen/gentags.ml
Normal file
|
|
@ -0,0 +1,380 @@
|
|||
|
||||
(* adapted from https://github.com/sindresorhus/html-tags (MIT licensed) *)
|
||||
|
||||
let pf = Printf.printf
|
||||
let spf = Printf.sprintf
|
||||
|
||||
let void = [
|
||||
"area";
|
||||
"base";
|
||||
"br";
|
||||
"col";
|
||||
"embed";
|
||||
"hr";
|
||||
"img";
|
||||
"input";
|
||||
"link";
|
||||
"menuitem";
|
||||
"meta";
|
||||
"param";
|
||||
"source";
|
||||
"track";
|
||||
"wbr";
|
||||
]
|
||||
|
||||
let normal = [
|
||||
"a";
|
||||
"abbr";
|
||||
"address";
|
||||
"area";
|
||||
"article";
|
||||
"aside";
|
||||
"audio";
|
||||
"b";
|
||||
"base";
|
||||
"bdi";
|
||||
"bdo";
|
||||
"blockquote";
|
||||
"body";
|
||||
"br";
|
||||
"button";
|
||||
"canvas";
|
||||
"caption";
|
||||
"cite";
|
||||
"code";
|
||||
"col";
|
||||
"colgroup";
|
||||
"data";
|
||||
"datalist";
|
||||
"dd";
|
||||
"del";
|
||||
"details";
|
||||
"dfn";
|
||||
"dialog";
|
||||
"div";
|
||||
"dl";
|
||||
"dt";
|
||||
"em";
|
||||
"embed";
|
||||
"fieldset";
|
||||
"figcaption";
|
||||
"figure";
|
||||
"footer";
|
||||
"form";
|
||||
"h1";
|
||||
"h2";
|
||||
"h3";
|
||||
"h4";
|
||||
"h5";
|
||||
"h6";
|
||||
"head";
|
||||
"header";
|
||||
"hgroup";
|
||||
"hr";
|
||||
"html";
|
||||
"i";
|
||||
"iframe";
|
||||
"img";
|
||||
"input";
|
||||
"ins";
|
||||
"kbd";
|
||||
"label";
|
||||
"legend";
|
||||
"li";
|
||||
"link";
|
||||
"main";
|
||||
"map";
|
||||
"mark";
|
||||
"math";
|
||||
"menu";
|
||||
"menuitem";
|
||||
"meta";
|
||||
"meter";
|
||||
"nav";
|
||||
"noscript";
|
||||
"object";
|
||||
"ol";
|
||||
"optgroup";
|
||||
"option";
|
||||
"output";
|
||||
"p";
|
||||
"param";
|
||||
"picture";
|
||||
"pre";
|
||||
"progress";
|
||||
"q";
|
||||
"rb";
|
||||
"rp";
|
||||
"rt";
|
||||
"rtc";
|
||||
"ruby";
|
||||
"s";
|
||||
"samp";
|
||||
"script";
|
||||
"section";
|
||||
"select";
|
||||
"slot";
|
||||
"small";
|
||||
"source";
|
||||
"span";
|
||||
"strong";
|
||||
"style";
|
||||
"sub";
|
||||
"summary";
|
||||
"sup";
|
||||
"svg";
|
||||
"table";
|
||||
"tbody";
|
||||
"td";
|
||||
"template";
|
||||
"textarea";
|
||||
"tfoot";
|
||||
"th";
|
||||
"thead";
|
||||
"time";
|
||||
"title";
|
||||
"tr";
|
||||
"track";
|
||||
"u";
|
||||
"ul";
|
||||
"var";
|
||||
"video";
|
||||
"wbr";
|
||||
] |> List.filter (fun s -> not (List.mem s void))
|
||||
|
||||
(* obtained via:
|
||||
{[
|
||||
l = Array(...document.querySelectorAll('div tbody td code a')).map(
|
||||
x => x.firstChild.textContent);
|
||||
JSON.stringify(l)
|
||||
]}
|
||||
on https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes
|
||||
*)
|
||||
let attrs = [
|
||||
"accept";
|
||||
"accept-charset";
|
||||
"accesskey";
|
||||
"action";
|
||||
"align";
|
||||
"allow";
|
||||
"alt";
|
||||
"async";
|
||||
"autocapitalize";
|
||||
"autocomplete";
|
||||
"autofocus";
|
||||
"autoplay";
|
||||
"buffered";
|
||||
"capture";
|
||||
"challenge";
|
||||
"charset";
|
||||
"checked";
|
||||
"cite";
|
||||
"class";
|
||||
"code";
|
||||
"codebase";
|
||||
"cols";
|
||||
"colspan";
|
||||
"content";
|
||||
"contenteditable";
|
||||
"contextmenu";
|
||||
"controls";
|
||||
"coords";
|
||||
"crossorigin";
|
||||
"csp";
|
||||
"data";
|
||||
"data-*";
|
||||
"datetime";
|
||||
"decoding";
|
||||
"default";
|
||||
"defer";
|
||||
"dir";
|
||||
"dirname";
|
||||
"disabled";
|
||||
"download";
|
||||
"draggable";
|
||||
"enctype";
|
||||
"enterkeyhint";
|
||||
"for";
|
||||
"form";
|
||||
"formaction";
|
||||
"formenctype";
|
||||
"formmethod";
|
||||
"formnovalidate";
|
||||
"formtarget";
|
||||
"headers";
|
||||
"hidden";
|
||||
"high";
|
||||
"href";
|
||||
"hreflang";
|
||||
"http-equiv";
|
||||
"icon";
|
||||
"id";
|
||||
"importance";
|
||||
"integrity";
|
||||
"ismap";
|
||||
"itemprop";
|
||||
"keytype";
|
||||
"kind";
|
||||
"label";
|
||||
"lang";
|
||||
"language";
|
||||
"list";
|
||||
"loop";
|
||||
"low";
|
||||
"manifest";
|
||||
"max";
|
||||
"maxlength";
|
||||
"minlength";
|
||||
"media";
|
||||
"method";
|
||||
"min";
|
||||
"multiple";
|
||||
"muted";
|
||||
"name";
|
||||
"novalidate";
|
||||
"open";
|
||||
"optimum";
|
||||
"pattern";
|
||||
"ping";
|
||||
"placeholder";
|
||||
"poster";
|
||||
"preload";
|
||||
"radiogroup";
|
||||
"readonly";
|
||||
"referrerpolicy";
|
||||
"rel";
|
||||
"required";
|
||||
"reversed";
|
||||
"rows";
|
||||
"rowspan";
|
||||
"sandbox";
|
||||
"scope";
|
||||
"scoped";
|
||||
"selected";
|
||||
"shape";
|
||||
"size";
|
||||
"sizes";
|
||||
"slot";
|
||||
"span";
|
||||
"spellcheck";
|
||||
"src";
|
||||
"srcdoc";
|
||||
"srclang";
|
||||
"srcset";
|
||||
"start";
|
||||
"step";
|
||||
"style";
|
||||
"summary";
|
||||
"tabindex";
|
||||
"target";
|
||||
"title";
|
||||
"translate";
|
||||
"Text";
|
||||
"type";
|
||||
"usemap";
|
||||
"value";
|
||||
"width";
|
||||
"wrap";
|
||||
]
|
||||
|
||||
let prelude = {|
|
||||
type attribute = string * string
|
||||
type elt = Buffer.t -> unit
|
||||
type void = attribute list -> elt
|
||||
type nary = attribute list -> elt list -> elt
|
||||
type nary' = attribute list -> (Buffer.t -> unit) -> elt
|
||||
|
||||
let str_escape (buf:Buffer.t) (s:string) : unit =
|
||||
String.iter (function
|
||||
| '<' -> Buffer.add_string buf "<"
|
||||
| '>' -> Buffer.add_string buf ">"
|
||||
| '&' -> Buffer.add_string buf "&"
|
||||
| '"' -> Buffer.add_string buf """
|
||||
| '\'' -> Buffer.add_string buf "'"
|
||||
| c -> Buffer.add_char buf c)
|
||||
s
|
||||
|
||||
(** Print the value part of an attribute *)
|
||||
let attr_escape buf (s:string) =
|
||||
Buffer.add_char buf '"';
|
||||
str_escape buf s;
|
||||
Buffer.add_char buf '"'
|
||||
|
||||
(** Emit a string value, which will be escaped. *)
|
||||
let txt (txt:string) : elt = fun buf -> str_escape buf txt
|
||||
|
||||
(** 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 buf -> Buffer.add_string buf s
|
||||
|}
|
||||
|
||||
let oname = function
|
||||
| "object" -> "object_"
|
||||
| "class" -> "class_"
|
||||
| "method" -> "method_"
|
||||
| "data-*" -> "data_star"
|
||||
| "for" -> "for_"
|
||||
| "open" -> "open_"
|
||||
| "Text" -> "text"
|
||||
| "type" -> "type_"
|
||||
| name ->
|
||||
String.map (function '-' -> '_' | c -> c) name
|
||||
|
||||
let emit_void name =
|
||||
let oname = oname name in
|
||||
pf "(** tag %S, see {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
|
||||
name name;
|
||||
pf "let %s : void = fun attrs buf ->\n" oname;
|
||||
pf " Buffer.add_string buf \"<%s\";\n" name;
|
||||
pf " List.iter (fun (k,v) -> Printf.bprintf buf \" %%s=%%a\" k attr_escape v) attrs;\n";
|
||||
pf " Buffer.add_string buf \"/>\"";
|
||||
pf "\n\n";
|
||||
()
|
||||
|
||||
let emit_normal name =
|
||||
let oname = oname name in
|
||||
|
||||
pf "(** tag %S, see {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
|
||||
name name;
|
||||
pf "let %s : nary = fun attrs sub buf ->\n" oname;
|
||||
pf " Buffer.add_string buf \"<%s\";\n" name;
|
||||
pf " List.iter (fun (k,v) -> Printf.bprintf buf \" %%s=%%a\" k attr_escape v) attrs;\n";
|
||||
pf " Buffer.add_string buf \">\\n\";\n";
|
||||
pf " List.iter (fun sub -> sub buf; Buffer.add_char buf '\\n') sub;\n";
|
||||
pf " Buffer.add_string buf \"</%s>\\n\"" name;
|
||||
pf "\n\n";
|
||||
|
||||
(* block version *)
|
||||
let oname = oname ^ "'" in
|
||||
pf "(** tag %S, see {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
|
||||
name name;
|
||||
pf "let %s : nary' = fun attrs f buf ->\n" oname;
|
||||
pf " Buffer.add_string buf \"<%s\";\n" name;
|
||||
pf " List.iter (fun (k,v) -> Printf.bprintf buf \" %%s=%%a\" k attr_escape v) attrs;\n";
|
||||
pf " Buffer.add_string buf \">\\n\";\n";
|
||||
pf " f buf;\n";
|
||||
pf " Buffer.add_string buf \"</%s>\\n\"" name;
|
||||
pf "\n\n";
|
||||
|
||||
|
||||
()
|
||||
|
||||
let emit_attr name =
|
||||
let oname = oname name in
|
||||
pf " (** Attribute %S. *)\n" name;
|
||||
pf " let %s : t = fun v -> %S, v\n" oname name;
|
||||
pf "\n"
|
||||
|
||||
let () =
|
||||
pf "%s\n" prelude;
|
||||
List.iter emit_void void;
|
||||
List.iter emit_normal normal;
|
||||
pf "(** Attributes *)\n";
|
||||
pf "module A = struct\n";
|
||||
pf " type t = string -> attribute\n";
|
||||
pf " (** Attribute builder *)\n";
|
||||
pf "\n";
|
||||
List.iter emit_attr attrs;
|
||||
pf "end\n";
|
||||
()
|
||||
|
||||
Loading…
Add table
Reference in a new issue