mirror of
https://github.com/c-cube/tiny_httpd.git
synced 2025-12-06 11:15:35 -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 Buf = Tiny_httpd_buf
|
||||||
|
|
||||||
module Byte_stream = Tiny_httpd_stream
|
module Byte_stream = Tiny_httpd_stream
|
||||||
|
|
@ -8,3 +16,5 @@ include Tiny_httpd_server
|
||||||
module Util = Tiny_httpd_util
|
module Util = Tiny_httpd_util
|
||||||
|
|
||||||
module Dir = Tiny_httpd_dir
|
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)
|
(libraries threads)
|
||||||
(flags :standard -safe-string -warn-error -a+8)
|
(flags :standard -safe-string -warn-error -a+8)
|
||||||
(wrapped false))
|
(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