Jon Sterling: 1 vendor dream-html to remove dep. on 'dream' and thus 'ssl' 11 files changed, 1925 insertions(+), 66 deletions(-)
Copy & paste the following snippet into your terminal to import this patchset into git:
curl -s https://lists.sr.ht/~jonsterling/forester-devel/patches/53306/mbox | git am -3Learn more about email & git
The 'ssl' package seems to be a consistent bad actor in regard to build breakage wrt. the system openssl dependency (see https://github.com/savonet/ocaml-ssl/issues/154). My new rule is that the core Forester tool should not depend on this library until such time as they adopt a practice that does not cause my build to irreparably break following every patch release of the system openssl dependency. I have proposed to change the dream-html library to not depend on dream here: https://github.com/yawaramin/dream-html/issues/28. Will be very happy to resume our dependency on dream-html if that idea is adopted. Signed-off-by: Jon Sterling <jon@jonmsterling.com> --- dune-project | 2 - forester.opam | 1 - forester.opam.locked | 77 +-- lib/frontend/Forest.ml | 3 +- lib/render/Dream_forester.ml | 4 +- lib/render/Dream_forester.mli | 2 +- lib/render/Dream_html_lite.ml | 936 ++++++++++++++++++++++++++++++++ lib/render/Dream_html_lite.mli | 960 +++++++++++++++++++++++++++++++++ lib/render/Render_dream.ml | 2 +- lib/render/dune | 2 +- test/dune | 2 +- 11 files changed, 1925 insertions(+), 66 deletions(-) create mode 100644 lib/render/Dream_html_lite.ml create mode 100644 lib/render/Dream_html_lite.mli diff --git a/dune-project b/dune-project index bfba6d3..09c67b2 100644 --- a/dune-project +++ b/dune-project @@ -52,8 +52,6 @@ (>= 2.0.0)) (yojson (>= 2.1.2)) - (dream-html - (>= 3.4.1)) (toml (>= 7.1.0)) (irmin-git diff --git a/forester.opam b/forester.opam index ffe4c88..5ee435a 100644 --- a/forester.opam +++ b/forester.opam @@ -23,7 +23,6 @@ depends: [ "bwd" {>= "2.3.0"} "algaeff" {>= "2.0.0"} "yojson" {>= "2.1.2"} - "dream-html" {>= "3.4.1"} "toml" {>= "7.1.0"} "irmin-git" {>= "3.9.0"} "odoc" {with-doc} diff --git a/forester.opam.locked b/forester.opam.locked index 627ad49..5c7a1cc 100644 --- a/forester.opam.locked +++ b/forester.opam.locked @@ -11,7 +11,7 @@ depends: [ "algaeff" {= "2.0.0"} "angstrom" {= "0.16.0"} "arp" {= "3.1.1"} - "asai" {= "0.3.0"} + "asai" {= "0.3.1"} "asn1-combinators" {= "0.2.6"} "astring" {= "0.8.5"} "awa" {= "0.3.1"} @@ -26,15 +26,11 @@ depends: [ "base64" {= "3.5.1"} "bheap" {= "2.0.0"} "bigarray-compat" {= "1.1.0"} - "bigarray-overlap" {= "0.2.1"} "bigstringaf" {= "0.9.1"} "bos" {= "0.2.1"} "bwd" {= "2.3.0"} "ca-certs" {= "0.2.3"} - "ca-certs-nss" {= "3.98"} - "camlp-streams" {= "5.0.1"} - "caqti" {= "2.1.1"} - "caqti-lwt" {= "2.1.1"} + "ca-certs-nss" {= "3.101"} "carton" {= "0.7.2"} "carton-git" {= "0.7.2"} "carton-lwt" {= "0.7.2"} @@ -45,14 +41,12 @@ depends: [ "cohttp" {= "5.3.1"} "cohttp-lwt" {= "5.3.0"} "cohttp-lwt-unix" {= "5.3.0"} - "conduit" {= "6.2.2"} - "conduit-lwt" {= "6.2.2"} - "conduit-lwt-unix" {= "6.2.2"} + "conduit" {= "6.2.3"} + "conduit-lwt" {= "6.2.3"} + "conduit-lwt-unix" {= "6.2.3"} "conf-gmp" {= "4"} "conf-gmp-powm-sec" {= "3"} - "conf-libev" {= "4-12"} "conf-libffi" {= "2.0.0"} - "conf-libssl" {= "4"} "conf-pkg-config" {= "3"} "cppo" {= "1.6.9"} "csexp" {= "1.5.2"} @@ -63,24 +57,15 @@ depends: [ "ctypes-foreign" {= "0.22.0"} "decompress" {= "1.5.3"} "digestif" {= "1.2.0"} - "dns" {= "7.0.3"} - "dns-client" {= "7.0.3"} - "dns-client-lwt" {= "7.0.3"} - "dns-client-mirage" {= "7.0.3"} + "dns" {= "8.0.0"} + "dns-client" {= "8.0.0"} "domain-local-await" {= "1.0.1"} "domain-name" {= "0.4.0"} - "dream" {= "1.0.0~alpha6"} - "dream-html" {= "3.4.1"} - "dream-httpaf" {= "1.0.0~alpha3"} - "dream-pure" {= "1.0.0~alpha2"} "duff" {= "0.5"} "dune" {= "3.15.3"} "dune-build-info" {= "3.15.3"} "dune-configurator" {= "3.15.3"} - "dune-private-libs" {= "3.15.3"} - "dune-site" {= "3.15.3"} "duration" {= "0.2.1"} - "dyn" {= "3.15.3"} "eio" {= "1.1"} "eio_main" {= "1.1"} "eio_posix" {= "1.1"} @@ -90,26 +75,23 @@ depends: [ "eqaf" {= "0.9"} "ethernet" {= "3.2.0"} "faraday" {= "0.8.2"} - "faraday-lwt" {= "0.8.2"} - "faraday-lwt-unix" {= "0.8.2"} "fmt" {= "0.9.0"} "fpath" {= "0.7.3"} "fsevents" {= "0.3.0"} "fsevents-lwt" {= "0.3.0"} - "git" {= "3.16.0"} - "git-mirage" {= "3.16.0"} - "git-paf" {= "3.16.0"} - "git-unix" {= "3.16.0"} + "git" {= "3.16.1"} + "git-mirage" {= "3.16.1"} + "git-paf" {= "3.16.1"} + "git-unix" {= "3.16.1"} "gmap" {= "0.3.0"} - "graphql" {= "0.14.0"} - "graphql-lwt" {= "0.14.0"} - "graphql_parser" {= "0.14.0"} "h2" {= "0.11.0"} - "happy-eyeballs" {= "0.6.0"} - "happy-eyeballs-lwt" {= "0.6.0"} - "happy-eyeballs-mirage" {= "0.6.0"} + "happy-eyeballs" {= "1.1.0"} + "happy-eyeballs-lwt" {= "1.1.0"} + "happy-eyeballs-mirage" {= "1.1.0"} "hkdf" {= "1.0.4"} "hmap" {= "0.8.1"} + "host-arch-arm64" {= "1"} + "host-system-other" {= "1"} "hpack" {= "0.11.0"} "httpaf" {= "0.7.1"} "hxd" {= "0.3.2"} @@ -124,31 +106,26 @@ depends: [ "irmin-watcher" {= "0.5.0"} "jsonm" {= "1.0.2"} "ke" {= "0.6"} - "lambdasoup" {= "1.0.0"} "logs" {= "0.7.0"} "lru" {= "0.3.1"} "lwt" {= "5.7.0"} "lwt-dllist" {= "1.0.1"} - "lwt_ppx" {= "2.1.0"} - "lwt_ssl" {= "1.2.0"} "macaddr" {= "5.6.0"} "macaddr-cstruct" {= "5.6.0"} "magic-mime" {= "1.3.1"} - "markup" {= "1.0.3"} "menhir" {= "20231231"} "menhirCST" {= "20231231"} "menhirLib" {= "20231231"} "menhirSdk" {= "20231231"} "metrics" {= "0.4.1"} - "mimic" {= "0.0.7"} - "mimic-happy-eyeballs" {= "0.0.7"} + "mimic" {= "0.0.8"} + "mimic-happy-eyeballs" {= "0.0.8"} "mirage-clock" {= "4.2.0"} "mirage-clock-unix" {= "4.2.0"} "mirage-crypto" {= "0.11.3"} "mirage-crypto-ec" {= "0.11.3"} "mirage-crypto-pk" {= "0.11.3"} "mirage-crypto-rng" {= "0.11.3"} - "mirage-crypto-rng-lwt" {= "0.11.3"} "mirage-flow" {= "4.0.2"} "mirage-kv" {= "6.1.1"} "mirage-net" {= "4.0.0"} @@ -157,12 +134,10 @@ depends: [ "mirage-time" {= "3.0.0"} "mirage-unix" {= "5.0.1"} "mtime" {= "2.0.0"} - "multipart_form" {= "0.6.0"} - "multipart_form-lwt" {= "0.6.0"} "num" {= "1.5"} - "ocaml" {= "5.1.1"} - "ocaml-base-compiler" {= "5.1.1"} - "ocaml-compiler-libs" {= "v0.12.4"} + "ocaml" {= "5.2.0"} + "ocaml-base-compiler" {= "5.2.0"} + "ocaml-compiler-libs" {= "v0.17.0"} "ocaml-config" {= "3"} "ocaml-options-vanilla" {= "1"} "ocaml-syntax-shims" {= "1.0.0"} @@ -172,12 +147,10 @@ depends: [ "ocamlgraph" {= "2.1.0"} "ocplib-endian" {= "1.2"} "optint" {= "0.3.0"} - "ordering" {= "3.15.3"} "paf" {= "0.6.0"} "parsexp" {= "v0.17.0"} "pbkdf" {= "1.2.0"} "pecu" {= "0.7"} - "pp" {= "1.2.0"} "ppx_derivers" {= "1.2.1"} "ppx_deriving" {= "6.0.2"} "ppx_irmin" {= "3.9.0"} @@ -185,7 +158,6 @@ depends: [ "ppx_sexp_conv" {= "v0.17.0"} "ppxlib" {= "0.32.1"} "ppxlib_jane" {= "v0.17.0"} - "prettym" {= "0.0.3"} "psq" {= "0.2.1"} "ptime" {= "1.1.0"} "randomconv" {= "0.1.3"} @@ -196,25 +168,20 @@ depends: [ "seq" {= "base"} "sexplib" {= "v0.17.0"} "sexplib0" {= "v0.17.0"} - "ssl" {= "0.7.0"} "stdlib-shims" {= "0.3.0"} - "stdune" {= "3.15.3"} "stringext" {= "1.6.0"} "tcpip" {= "8.1.0"} "thread-table" {= "1.0.0"} "tls" {= "0.17.5"} - "tls-lwt" {= "0.17.5"} "tls-mirage" {= "0.17.5"} "toml" {= "7.1.0"} "topkg" {= "1.0.7"} - "uchar" {= "0.0.2"} - "unstrctrd" {= "0.4"} "uri" {= "4.4.0"} "uri-sexp" {= "4.4.0"} "uucp" {= "15.1.0"} "uutf" {= "1.0.3"} "x509" {= "0.16.5"} - "yojson" {= "2.1.2"} + "yojson" {= "2.2.1"} "yuujinchou" {= "5.2.0"} "zarith" {= "1.13"} ] diff --git a/lib/frontend/Forest.ml b/lib/frontend/Forest.ml index 59b8c95..4929f1a 100644 --- a/lib/frontend/Forest.ml +++ b/lib/frontend/Forest.ml @@ -274,7 +274,7 @@ let render_tree ~cfg ~cwd (tree : Sem.tree) = Format.pp_print_newline fmt (); Format.fprintf fmt "<?xml-stylesheet type=\"text/xsl\" href=\"%s\"?>" cfg.stylesheet; Format.pp_print_newline fmt (); - Dream_html.pp fmt node + Dream_html_lite.pp fmt node end let render_json ~cwd docs = @@ -287,7 +287,6 @@ let is_hidden_file fname = let copy_theme ~env ~theme_dir = let cwd = Eio.Stdenv.cwd env in - let fs = Eio.Stdenv.fs env in Eio.Path.with_open_dir theme_dir @@ fun theme -> Eio.Path.read_dir theme |> List.iter @@ fun fname -> if not @@ is_hidden_file fname then diff --git a/lib/render/Dream_forester.ml b/lib/render/Dream_forester.ml index edf7878..ab4ae4b 100644 --- a/lib/render/Dream_forester.ml +++ b/lib/render/Dream_forester.ml @@ -1,4 +1,4 @@ -open Dream_html +open Dream_html_lite let reserved_prefix = "fr" let forester_xmlns = "http://www.jonmsterling.com/jms-005P.xml" @@ -92,4 +92,4 @@ let src fmt = uri_attr "src" fmt let embedded_tex = f_std_tag "embedded-tex" let embedded_tex_preamble attrs = f_text_tag "embedded-tex-preamble" attrs let embedded_tex_body attrs = f_text_tag "embedded-tex-body" attrs -let hash fmt = string_attr "hash" fmt \ No newline at end of file +let hash fmt = string_attr "hash" fmt diff --git a/lib/render/Dream_forester.mli b/lib/render/Dream_forester.mli index 09dc0d8..bc31f97 100644 --- a/lib/render/Dream_forester.mli +++ b/lib/render/Dream_forester.mli @@ -1,4 +1,4 @@ -open Dream_html +open Dream_html_lite open Core val reserved_prefix : string diff --git a/lib/render/Dream_html_lite.ml b/lib/render/Dream_html_lite.ml new file mode 100644 index 0000000..a47883e --- /dev/null +++ b/lib/render/Dream_html_lite.ml @@ -0,0 +1,936 @@ +(* Copyright 2023 Yawar Amin + + This file is part of dream-html. + + dream-html is free software: you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at your option) any + later version. + + dream-html is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along with + dream-html. If not, see <https://www.gnu.org/licenses/>. *) + +type attr = string * string + +type tag = + { name : string; + attrs : attr list; + children : node list option + } + +and node = + | Tag of tag + | Txt of string + | Comment of string + +type 'a to_attr = 'a -> attr +type 'a string_attr = ('a, unit, string, attr) format4 -> 'a +type std_tag = attr list -> node list -> node +type void_tag = attr list -> node +type 'a text_tag = attr list -> ('a, unit, string, node) format4 -> 'a + +let write_attr p = function + | "", _ -> () + | name, "" -> + p "\n"; + p name + | name, value -> + p "\n"; + p name; + p {|="|}; + p value; + p {|"|} + +(* Loosely based on https://www.w3.org/TR/DOM-Parsing/ *) +let rec write_tag ~xml p = function + | Tag { name = ""; children = Some children; _ } -> + List.iter (write_tag ~xml p) children + | Tag { name; attrs; children = Some [] } when xml -> + p "<"; + p name; + List.iter (write_attr p) attrs; + p " />" + | Tag { name; attrs; children = None } -> + p "<"; + p name; + List.iter (write_attr p) attrs; + p (if xml then " />" else ">") + | Tag { name; attrs; children = Some children } -> + if name = "html" then p "<!DOCTYPE html>\n"; + p "<"; + p name; + List.iter (write_attr p) attrs; + p ">"; + List.iter (write_tag ~xml p) children; + p "</"; + p name; + p ">" + | Txt str -> p str + | Comment str -> + p "<!-- "; + p str; + p " -->" + +let to_string ~xml node = + let buf = Buffer.create 256 in + write_tag ~xml (Buffer.add_string buf) node; + Buffer.contents buf + +let pp ppf node = node |> to_string ~xml:false |> Format.pp_print_string ppf +let to_xml = to_string ~xml:true +let to_string = to_string ~xml:false +let pp_xml ppf node = node |> to_xml |> Format.pp_print_string ppf + +let txt_escape buffer = function + | '&' -> Buffer.add_string buffer "&" + | '<' -> Buffer.add_string buffer "<" + | '>' -> Buffer.add_string buffer ">" + | c -> Buffer.add_char buffer c + +let txt_escape raw s = + if raw then + s + else + let buffer = Buffer.create (String.length s * 2) in + String.iter (txt_escape buffer) s; + Buffer.contents buffer + +let attr_escape buffer = function + | '&' -> Buffer.add_string buffer "&" + | '"' -> Buffer.add_string buffer """ + | c -> Buffer.add_char buffer c + +let attr_escape raw s = + if raw then + s + else + let buffer = Buffer.create (String.length s * 2) in + String.iter (attr_escape buffer) s; + Buffer.contents buffer + +let attr name = name, "" + +let string_attr name ?(raw = false) fmt = + Printf.ksprintf (fun s -> name, attr_escape raw s) fmt + +let uri_attr name fmt = + Printf.ksprintf + (fun s -> name, s |> Uri.of_string |> Uri.to_string |> attr_escape false) + fmt + +let bool_attr name value = name, string_of_bool value +let float_attr name value = name, Printf.sprintf "%f" value +let int_attr name value = name, string_of_int value +let std_tag name attrs children = Tag { name; attrs; children = Some children } +let void_tag name attrs = Tag { name; attrs; children = None } + +let text_tag name ?(raw = false) attrs fmt = + Printf.ksprintf + (fun s -> Tag { name; attrs; children = Some [Txt (txt_escape raw s)] }) + fmt + +let txt ?(raw = false) fmt = + Printf.ksprintf (fun s -> Txt (txt_escape raw s)) fmt + +let comment str = Comment (txt_escape false str) + +let ( +@ ) node attr = + match node with + | Tag t -> Tag { t with attrs = attr :: t.attrs } + | _ -> invalid_arg "cannot add attribute to non-tag node" + +let ( -@ ) node attr = + match node with + | Tag t -> + Tag { t with attrs = List.filter (fun (k, _) -> k <> attr) t.attrs } + | _ -> invalid_arg "cannot remove attribute from non-tag node" + +let ( .@[] ) node attr = + match node with + | Tag { attrs; _ } -> List.assoc attr attrs + | _ -> invalid_arg "cannot get value of attribute from non-tag node" + +let is_null = function + | Tag { name = ""; _ } -> true + | _ -> false + +let is_null_ (name, _) = name = "" + +module HTML = struct + (* Attributes *) + + type method_ = + [ `GET + | `POST + | `dialog ] + + type enctype = + [ `urlencoded + | `formdata + | `text_plain ] + + let enctype_string = function + | `urlencoded -> "application/x-www-form-urlencoded" + | `formdata -> "multipart/form-data" + | `text_plain -> "text/plain" + + let null_ = string_attr "" "" + let accept fmt = string_attr "accept" fmt + let accept_charset fmt = string_attr "accept-charset" fmt + let accesskey fmt = string_attr "accesskey" fmt + let action fmt = uri_attr "action" fmt + let align fmt = string_attr "align" fmt + let allow fmt = string_attr "allow" fmt + let alt fmt = string_attr "alt" fmt + let async = attr "async" + + let autocapitalize value = + ( "autocapitalize", + match value with + | `off -> "off" + | `none -> "none" + | `on -> "on" + | `sentences -> "sentences" + | `words -> "words" + | `characters -> "characters" ) + + let autocomplete value = + ( "autocomplete", + match value with + | `off -> "off" + | `on -> "on" + | `name -> "name" + | `honorific_prefix -> "honorific-prefix" + | `given_name -> "given-name" + | `additional_name -> "additional-name" + | `honorific_suffix -> "honorific-suffix" + | `nickname -> "nickname" + | `email -> "email" + | `username -> "username" + | `new_password -> "new-password" + | `current_password -> "current-password" + | `one_time_code -> "one-time-code" + | `organization_title -> "organization-title" + | `organization -> "organization" + | `street_address -> "street-address" + | `address_line1 -> "address-line1" + | `address_line2 -> "address-line2" + | `address_line3 -> "address-line3" + | `address_level4 -> "address-level4" + | `address_level3 -> "address-level3" + | `address_level2 -> "address-level2" + | `address_level1 -> "address-level1" + | `country -> "country" + | `country_name -> "country-name" + | `postal_code -> "postal-code" + | `cc_name -> "cc-name" + | `cc_given_name -> "cc-given-name" + | `cc_additional_name -> "cc-additional-name" + | `cc_family_name -> "cc-family-name" + | `cc_number -> "cc-number" + | `cc_exp -> "cc-exp" + | `cc_exp_month -> "cc-exp-month" + | `cc_exp_year -> "cc-exp-year" + | `cc_csc -> "cc-csc" + | `cc_type -> "cc-type" + | `transaction_currency -> "transaction-currency" + | `transaction_amount -> "transaction-amount" + | `language -> "language" + | `bday -> "bday" + | `bday_day -> "bday-day" + | `bday_month -> "bday-month" + | `bday_year -> "bday-year" + | `sex -> "sex" + | `tel -> "tel" + | `tel_country_code -> "tel-country-code" + | `tel_national -> "tel-national" + | `tel_area_code -> "tel-area-code" + | `tel_local -> "tel-local" + | `tel_extension -> "tel-extension" + | `impp -> "impp" + | `url -> "url" + | `photo -> "photo" + | `webauthn -> "webauthn" ) + + let autofocus = attr "autofocus" + let autoplay = attr "autoplay" + let buffered fmt = string_attr "buffered" fmt + + let capture value = + ( "capture", + match value with + | `user -> "user" + | `environment -> "environment" ) + + let charset fmt = string_attr "charset" fmt + let checked = attr "checked" + let cite_ fmt = uri_attr "cite" fmt + let class_ fmt = string_attr "class" fmt + let color fmt = string_attr "color" fmt + let cols = int_attr "cols" + let colspan = int_attr "colspan" + let content fmt = string_attr "content" fmt + let contenteditable = bool_attr "contenteditable" + let contextmenu fmt = string_attr "contextmenu" fmt + let controls = attr "controls" + let coords fmt = string_attr "coords" fmt + + let crossorigin value = + ( "crossorigin", + match value with + | `anonymous -> "anonymous" + | `use_credentials -> "use-credentials" ) + + let data_ fmt = uri_attr "data" fmt + let datetime fmt = string_attr "datetime" fmt + + let decoding value = + ( "decoding", + match value with + | `sync -> "sync" + | `async -> "async" + | `auto -> "auto" ) + + let default = attr "default" + let defer = attr "defer" + + let dir value = + ( "dir", + match value with + | `ltr -> "ltr" + | `rtl -> "rtl" + | `auto -> "auto" ) + + let dirname fmt = string_attr "dirname" fmt + let disabled = attr "disabled" + let download fmt = string_attr "download" fmt + let draggable = attr "draggable" + let enctype value = "enctype", enctype_string value + + let fetchpriority value = + ( "fetchpriority", + match value with + | `high -> "high" + | `low -> "low" + | `auto -> "auto" ) + + let for_ fmt = string_attr "for" fmt + let form_ fmt = string_attr "form" fmt + let formaction fmt = string_attr "formaction" fmt + let formenctype value = "formenctype", enctype_string value + + let method_to_string = function + | `GET -> "get" + | `POST -> "post" + | `dialog -> "dialog" + + let formmethod value = "formmethod", method_to_string value + let formnovalidate = attr "formnovalidate" + let formtarget fmt = string_attr "formtarget" fmt + let headers fmt = string_attr "headers" fmt + let height fmt = string_attr "height" fmt + + let hidden value = + ( "hidden", + match value with + | `hidden -> "hidden" + | `until_found -> "until-found" ) + + let high = float_attr "high" + let href fmt = uri_attr "href" fmt + let hreflang fmt = string_attr "hreflang" fmt + + let http_equiv value = + ( "http-equiv", + match value with + | `content_security_policy -> "content-security-policy" + | `content_type -> "content-type" + | `default_style -> "default-style" + | `x_ua_compatible -> "x-ua-compatible" + | `refresh -> "refresh" ) + + let id fmt = string_attr "id" fmt + let integrity fmt = string_attr "integrity" fmt + + let inputmode value = + ( "inputmode", + match value with + | `none -> "none" + | `text -> "text" + | `decimal -> "decimal" + | `numeric -> "numeric" + | `tel -> "tel" + | `search -> "search" + | `email -> "email" + | `url -> "url" ) + + let ismap = attr "ismap" + let itemprop fmt = string_attr "itemprop" fmt + + let kind value = + ( "kind", + match value with + | `subtitles -> "subtitles" + | `captions -> "captions" + | `descriptions -> "descriptions" + | `chapters -> "chapters" + | `metadata -> "metadata" ) + + let label_ fmt = string_attr "label" fmt + let lang fmt = string_attr "lang" fmt + let list fmt = string_attr "list" fmt + let loading_lazy = string_attr "loading" "lazy" + let loop = attr "loop" + let low = float_attr "low" + let max fmt = string_attr "max" fmt + let maxlength = int_attr "maxlength" + let media fmt = string_attr "media" fmt + let method_ value = "method", method_to_string value + let min fmt = string_attr "min" fmt + let minlength = int_attr "minlength" + let multiple = attr "multiple" + let muted = attr "muted" + let name fmt = string_attr "name" fmt + let novalidate = attr "novalidate" + let onblur fmt = string_attr "onblur" ~raw:true fmt + let onclick fmt = string_attr "onclick" ~raw:true fmt + let open_ = attr "open" + let optimum = float_attr "optimum" + let pattern fmt = string_attr "pattern" fmt + let ping fmt = string_attr "ping" fmt + let placeholder fmt = string_attr "placeholder" fmt + let playsinline = attr "playsinline" + let poster fmt = uri_attr "poster" fmt + + let preload value = + ( "preload", + match value with + | `none -> "none" + | `metadata -> "metadata" + | `auto -> "auto" ) + + let readonly = attr "readonly" + + let referrerpolicy value = + ( "referrerpolicy", + match value with + | `no_referrer -> "no-referrer" + | `no_referrer_when_downgrade -> "no-referrer-when-downgrade" + | `origin -> "origin" + | `origin_when_cross_origin -> "origin-when-cross-origin" + | `same_origin -> "same-origin" + | `strict_origin -> "strict-origin" + | `strict_origin_when_cross_origin -> "strict-origin-when-cross-origin" + | `unsafe_url -> "unsafe-url" ) + + let rel fmt = string_attr "rel" fmt + let required = attr "required" + let reversed = attr "reversed" + + let role value = + ( "role", + match value with + | `alert -> "alert" + | `alertdialog -> "alertdialog" + | `application -> "application" + | `article -> "article" + | `banner -> "banner" + | `button -> "button" + | `cell -> "cell" + | `checkbox -> "checkbox" + | `columnheader -> "columnheader" + | `combobox -> "combobox" + | `comment -> "comment" + | `complementary -> "complementary" + | `contentinfo -> "contentinfo" + | `definition -> "definition" + | `dialog -> "dialog" + | `document -> "document" + | `feed -> "feed" + | `figure -> "figure" + | `form -> "form" + | `generic -> "generic" + | `grid -> "grid" + | `gridcell -> "gridcell" + | `group -> "group" + | `heading -> "heading" + | `img -> "img" + | `link -> "link" + | `list -> "list" + | `listbox -> "listbox" + | `listitem -> "listitem" + | `log -> "log" + | `main -> "main" + | `mark -> "mark" + | `marquee -> "marquee" + | `math -> "math" + | `menu -> "menu" + | `menubar -> "menubar" + | `menuitem -> "menuitem" + | `menuitemcheckbox -> "menuitemcheckbox" + | `menuitemradio -> "menuitemradio" + | `meter -> "meter" + | `navigation -> "navigation" + | `none -> "none" + | `note -> "note" + | `option -> "option" + | `presentation -> "presentation" + | `progressbar -> "progressbar" + | `radio -> "radio" + | `radiogroup -> "radiogroup" + | `region -> "region" + | `row -> "row" + | `rowgroup -> "rowgroup" + | `rowheader -> "rowheader" + | `scrollbar -> "scrollbar" + | `search -> "search" + | `searchbox -> "searchbox" + | `separator -> "separator" + | `slider -> "slider" + | `spinbutton -> "spinbutton" + | `status -> "status" + | `suggestion -> "suggestion" + | `switch -> "switch" + | `tab -> "tab" + | `table -> "table" + | `tablist -> "tablist" + | `tabpanel -> "tabpanel" + | `term -> "term" + | `textbox -> "textbox" + | `timer -> "timer" + | `toolbar -> "toolbar" + | `tooltip -> "tooltip" + | `tree -> "tree" + | `treegrid -> "treegrid" + | `treeitem -> "treeitem" ) + + let rows = int_attr "rows" + let rowspan = int_attr "rowspan" + let sandbox fmt = string_attr "sandbox" fmt + let scope fmt = string_attr "scope" fmt + let selected = attr "selected" + let shape fmt = string_attr "shape" fmt + let size fmt = string_attr "size" fmt + let sizes fmt = string_attr "sizes" fmt + let slot_ fmt = string_attr "slot" fmt + let span_ = int_attr "span" + let spellcheck = bool_attr "spellcheck" + let src fmt = uri_attr "src" fmt + let srcdoc fmt = string_attr "srcdoc" fmt + let srclang fmt = string_attr "srclang" fmt + let srcset fmt = string_attr "srcset" fmt + let start = int_attr "start" + let step fmt = string_attr "step" fmt + let style_ fmt = string_attr ~raw:true "style" fmt + let tabindex = int_attr "tabindex" + let target fmt = string_attr "target" fmt + let title_ fmt = string_attr "title" fmt + + let translate value = + ( "translate", + match value with + | `yes -> "yes" + | `no -> "no" ) + + let type_ fmt = string_attr "type" fmt + let usemap fmt = string_attr "usemap" fmt + let value fmt = string_attr "value" fmt + let width fmt = string_attr "width" fmt + + let wrap value = + ( "wrap", + match value with + | `hard -> "hard" + | `soft -> "soft" ) + + (* Tags *) + + let null = std_tag "" [] + let a = std_tag "a" + let address = std_tag "address" + let abbr = std_tag "abbr" + let area = void_tag "area" + let article = std_tag "article" + let aside = std_tag "aside" + let audio = std_tag "audio" + let b = std_tag "b" + let base = void_tag "base" + let bdi = std_tag "bdi" + let bdo = std_tag "bdo" + let blockquote = std_tag "blockquote" + let br = void_tag "br" + let body = std_tag "body" + let button = std_tag "button" + let canvas = std_tag "canvas" + let caption = std_tag "caption" + let cite = std_tag "cite" + let code = std_tag "code" + let col = void_tag "col" + let colgroup = std_tag "colgroup" + let data = std_tag "data" + let datalist = std_tag "datalist" + let dd = std_tag "dd" + let del = std_tag "del" + let details = std_tag "details" + let dfn = std_tag "dfn" + let dialog = std_tag "dialog" + let div = std_tag "div" + let dl = std_tag "dl" + let dt = std_tag "dt" + let em = std_tag "em" + let embed = void_tag "embed" + let fieldset = std_tag "fieldset" + let figcaption = std_tag "figcaption" + let figure = std_tag "figure" + let footer = std_tag "footer" + let form = std_tag "form" + let h1 = std_tag "h1" + let h2 = std_tag "h2" + let h3 = std_tag "h3" + let h4 = std_tag "h4" + let h5 = std_tag "h5" + let h6 = std_tag "h6" + let head = std_tag "head" + let header = std_tag "header" + let hgroup = std_tag "hgroup" + let hr = void_tag "hr" + let html = std_tag "html" + let i = std_tag "i" + let iframe = std_tag "iframe" + let img = void_tag "img" + let input = void_tag "input" + let ins = std_tag "ins" + let kbd = std_tag "kbd" + let label = std_tag "label" + let legend = std_tag "legend" + let li = std_tag "li" + let link = void_tag "link" + let main = std_tag "main" + let map = std_tag "map" + let mark = std_tag "mark" + let menu = std_tag "menu" + let meta = void_tag "meta" + let meter = std_tag "meter" + let nav = std_tag "nav" + let noscript = std_tag "noscript" + let object_ = std_tag "object" + let ol = std_tag "ol" + let optgroup = std_tag "optgroup" + let option attrs fmt = text_tag "option" attrs fmt + let output = std_tag "output" + let p = std_tag "p" + let picture = std_tag "picture" + let pre = std_tag "pre" + let progress = std_tag "progress" + let q = std_tag "q" + let rp = std_tag "rp" + let rt = std_tag "rt" + let ruby = std_tag "ruby" + let s = std_tag "s" + let samp = std_tag "samp" + let script attrs fmt = text_tag "script" ~raw:true attrs fmt + let section = std_tag "section" + let select = std_tag "select" + let slot = std_tag "slot" + let small = std_tag "small" + let source = void_tag "source" + let span = std_tag "span" + let strong = std_tag "strong" + let style attrs fmt = text_tag "style" ~raw:true attrs fmt + let sub = std_tag "sub" + let sup = std_tag "sup" + let summary = std_tag "summary" + let table = std_tag "table" + let tbody = std_tag "tbody" + let td = std_tag "td" + let template = std_tag "template" + let textarea attrs fmt = text_tag "textarea" attrs fmt + let tfoot = std_tag "tfoot" + let th = std_tag "th" + let thead = std_tag "thead" + let time = std_tag "time" + let title attrs fmt = text_tag "title" attrs fmt + let tr = std_tag "tr" + let track = void_tag "track" + let u = std_tag "u" + let ul = std_tag "ul" + let var = std_tag "var" + let video = std_tag "video" + let wbr = void_tag "wbr" +end + +module SVG = struct + (* Attributes *) + let d fmt = string_attr "d" fmt + let fill fmt = string_attr "fill" fmt + let stroke fmt = string_attr "stroke" fmt + + let stroke_linecap value = + ( "stroke-linecap", + match value with + | `butt -> "butt" + | `round -> "round" + | `square -> "square" ) + + let stroke_linejoin value = + ( "stroke-linejoin", + match value with + | `arcs -> "arcs" + | `bevel -> "bevel" + | `miter -> "miter" + | `miter_clip -> "miter-clip" + | `round -> "round" ) + + let stroke_width fmt = string_attr "stroke-width" fmt + + let viewbox ~min_x ~min_y ~width ~height = + "viewbox", Printf.sprintf "%d %d %d %d" min_x min_y width height + + let xmlns = string_attr "xmlns" "http://www.w3.org/2000/svg" + + (* Tags *) + let path = std_tag "path" + let svg = std_tag "svg" +end + +module Aria = struct + let activedescendant fmt = string_attr "aria-activedescendant" fmt + let atomic = attr "aria-atomic" + + let autocomplete value = + ( "aria-autocomplete", + match value with + | `inline -> "inline" + | `list -> "list" + | `both -> "both" ) + + let braillelabel fmt = string_attr "aria-braillelabel" fmt + let brailleroledescription fmt = string_attr "aria-brailleroledescription" fmt + let busy = attr "aria-busy" + + let checked value = + ( "aria-checked", + match value with + | `false_ -> "false" + | `true_ -> "true" + | `mixed -> "mixed" ) + + let colcount = int_attr "aria-colcount" + let colindextext fmt = string_attr "aria-colindextext" fmt + let colspan = int_attr "aria-colspan" + let controls fmt = string_attr "aria-controls" fmt + + let current value = + ( "aria-current", + match value with + | `page -> "page" + | `step -> "step" + | `location -> "location" + | `date -> "date" + | `time -> "time" + | `true_ -> "true" ) + + let describedby fmt = string_attr "aria-describedby" fmt + let description fmt = string_attr "aria-description" fmt + let details fmt = string_attr "aria-details" fmt + let disabled = attr "aria-disabled" + let errormessage fmt = string_attr "aria-errormessage" fmt + let expanded = bool_attr "aria-expanded" + let flowto fmt = string_attr "aria-flowto" fmt + + let haspopup value = + ( "aria-haspopup", + match value with + | `true_ -> "true" + | `menu -> "menu" + | `listbox -> "listbox" + | `tree -> "tree" + | `grid -> "grid" + | `dialog -> "dialog" ) + + let hidden = bool_attr "aria-hidden" + + let invalid value = + ( "aria-invalid", + match value with + | `grammar -> "grammar" + | `spelling -> "spelling" + | `true_ -> "true" ) + + let keyshortcuts fmt = string_attr "aria-keyshortcuts" fmt + let label fmt = string_attr "aria-label" fmt + let labelledby fmt = string_attr "aria-labelledby" fmt + let level = int_attr "aria-level" + + let live value = + ( "aria-live", + match value with + | `assertive -> "assertive" + | `polite -> "polite" ) + + let modal = attr "aria-modal" + let multiline = attr "aria-multiline" + let multiselectable = attr "aria-multiselectable" + + let orientation value = + ( "aria-orientation", + match value with + | `horizontal -> "horizontal" + | `vertical -> "vertical" ) + + let owns fmt = string_attr "aria-owns" fmt + let placeholder fmt = string_attr "aria-placeholder" fmt + let posinset = int_attr "aria-posinset" + + let pressed value = + ( "aria-pressed", + match value with + | `false_ -> "false" + | `mixed -> "mixed" + | `true_ -> "true" ) + + let readonly = attr "aria-readonly" + + let relevant value = + ( "aria-relevant", + match value with + | `additions -> "additions" + | `all -> "all" + | `removals -> "removals" + | `text -> "text" ) + + let required = attr "aria-required" + let roledescription fmt = string_attr "aria-roledescription" fmt + let rowcount = int_attr "aria-rowcount" + let rowindex = int_attr "aria-rowindex" + let rowindextext fmt = string_attr "aria-rowindextext" fmt + let rowspan = int_attr "aria-rowspan" + let selected = bool_attr "aria-selected" + let setsize = int_attr "aria-setsize" + + let sort value = + ( "aria-sort", + match value with + | `ascending -> "ascending" + | `descending -> "descending" + | `other -> "other" ) + + let valuemax = float_attr "aria-valuemax" + let valuemin = float_attr "aria-valuemin" + let valuenow = float_attr "aria-valuenow" + let valuetext fmt = string_attr "aria-valuetext" fmt +end + +module Hx = struct + let __ fmt = string_attr ~raw:true "_" fmt + + (* This is a boolean because it can be selectively switched off in some parts + of the page. *) + let boost = bool_attr "data-hx-boost" + let confirm fmt = string_attr "data-hx-confirm" fmt + let delete fmt = uri_attr "data-hx-delete" fmt + let disable = attr "data-hx-disable" + let disinherit fmt = string_attr "data-hx-disinherit" fmt + let encoding_formdata = "data-hx-encoding", "multipart/form-data" + let ext fmt = string_attr "data-hx-ext" fmt + let get fmt = uri_attr "data-hx-get" fmt + let headers fmt = string_attr "data-hx-headers" fmt + let history_false = bool_attr "data-hx-history" false + let history_elt = attr "data-hx-history-elt" + let include_ fmt = string_attr "data-hx-include" fmt + let indicator fmt = string_attr ~raw:true "data-hx-indicator" fmt + let on fmt = string_attr "data-hx-on" ~raw:true fmt + let on_ ~event fmt = string_attr ("data-hx-on:" ^ event) ~raw:true fmt + let params fmt = string_attr "data-hx-params" fmt + let patch fmt = uri_attr "data-hx-patch" fmt + let post fmt = uri_attr "data-hx-post" fmt + let preload = attr "preload" + let preserve = attr "data-hx-preserve" + let prompt fmt = string_attr "data-hx-prompt" fmt + let push_url fmt = uri_attr "data-hx-push-url" fmt + let put fmt = uri_attr "data-hx-put" fmt + let replace_url fmt = string_attr "data-hx-replace-url" fmt + let request fmt = string_attr "data-hx-request" fmt + let select fmt = string_attr ~raw:true "data-hx-select" fmt + let select_oob fmt = string_attr ~raw:true "data-hx-select-oob" fmt + let sse_connect fmt = string_attr "data-sse-connect" fmt + let sse_swap fmt = string_attr "data-sse-swap" fmt + let swap fmt = string_attr ~raw:true "data-hx-swap" fmt + let swap_oob fmt = string_attr ~raw:true "data-hx-swap-oob" fmt + let sync fmt = string_attr "data-hx-sync" fmt + let target fmt = string_attr ~raw:true "data-hx-target" fmt + let trigger fmt = string_attr "data-hx-trigger" ~raw:true fmt + let validate = attr "data-hx-validate" + let vals fmt = string_attr "data-hx-vals" fmt + let ws_connect fmt = string_attr "data-ws-connect" fmt + let ws_send = attr "data-ws-send" +end + +module MathML = struct + (* Attributes *) + let accent = bool_attr "accent" + let accentunder = bool_attr "accentunder" + let columnspan = int_attr "columnspan" + let depth fmt = string_attr "depth" fmt + + let dir value = + ( "dir", + match value with + | `rtl -> "rtl" + | `ltr -> "ltr" ) + + let display_block = string_attr "display" "block" + let displaystyle = bool_attr "displaystyle" + let fence = bool_attr "fence" + let height fmt = string_attr "height" fmt + let largeop = bool_attr "largeop" + let linethickness fmt = string_attr "linethickness" fmt + let lspace fmt = string_attr "lspace" fmt + let mathvariant fmt = string_attr "mathvariant" fmt + let maxsize fmt = string_attr "maxsize" fmt + let minsize fmt = string_attr "minsize" fmt + let movablelimits = bool_attr "movablelimits" + let rowspan = int_attr "rowspan" + let rspace fmt = string_attr "rspace" fmt + let scriptlevel fmt = string_attr "scriptlevel" fmt + let separator = bool_attr "separator" + let stretchy = bool_attr "stretchy" + let symmetric = bool_attr "symmetric" + let voffset fmt = string_attr "voffset" fmt + let xmlns = string_attr "xmlns" "http://www.w3.1998/Math/MathML" + + (* Tags *) + let annotation = std_tag "annotation" + let annotation_xml = std_tag "annotation-xml" + let math = std_tag "math" + let merror = std_tag "merror" + let mfrac = std_tag "mfrac" + let mi = std_tag "mi" + let mmultiscripts = std_tag "mmultiscripts" + let mn = std_tag "mn" + let mo = std_tag "mo" + let mover = std_tag "mover" + let mpadded = std_tag "mpadded" + let mphantom = std_tag "mphantom" + let mroot = std_tag "mroot" + let mrow = std_tag "mrow" + let ms = std_tag "ms" + let mspace = std_tag "mspace" + let msqrt = std_tag "msqrt" + let mstyle = std_tag "mstyle" + let msub = std_tag "msub" + let msubsup = std_tag "msubsup" + let msup = std_tag "msup" + let mtable = std_tag "mtable" + let mtd = std_tag "mtd" + let mtext = std_tag "mtext" + let mtr = std_tag "mtr" + let munder = std_tag "munder" + let munderover = std_tag "munderover" + let semantics = std_tag "semantics" +end diff --git a/lib/render/Dream_html_lite.mli b/lib/render/Dream_html_lite.mli new file mode 100644 index 0000000..870eb8d --- /dev/null +++ b/lib/render/Dream_html_lite.mli @@ -0,0 +1,960 @@ +(* Copyright 2023 Yawar Amin + + This file is part of dream-html. + + dream-html is free software: you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at your option) any + later version. + + dream-html is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along with + dream-html. If not, see <https://www.gnu.org/licenses/>. *) + +(** Constructing HTML. Detailed explanation in + {: https://github.com/yawaramin/dream-html}. + + Let's adapt the example from the + {{: https://aantron.github.io/dream/} Dream home page}: + + + {[let hello who = + let open Dream_html in + let open HTML in + html [] [ + body [] [ + h1 [] [txt "Hello, %s!" who]; + ]; + ] + + let () = + Dream.run + @@ Dream.logger + @@ Dream.router [Dream.get "/" (fun _ -> Dream_html.respond (hello "world"))]]} + + More examples shown below. + + Note that the version of this library installed on your device may have + outdated documentation strings. To view the latest documentation, please + visit {{: https://github.com/yawaramin/dream-html} the repository page}. *) + +(** {2 Core types} + + These are the types of the final values which get rendered. *) + +type attr +(** E.g. [id="toast"]. *) + +type node +(** Either a tag, a comment, or text data in the markup. *) + +(** {2 Output} *) + +val to_string : node -> string + +val to_xml : node -> string +(** Same as [to_string] but render void tags as XML-style self-closing tags. + + @since 3.3.0. *) + +val pp : Format.formatter -> node -> unit + +val pp_xml : Format.formatter -> node -> unit +(** Same as [pp] but render void tags as XML-style self-closing tags. + + @since 3.3.0. *) + +(** {2 Constructing nodes and attributes} *) + +type 'a to_attr = 'a -> attr +(** Attributes can be created from typed values. *) + +type 'a string_attr = ('a, unit, string, attr) format4 -> 'a +(** Special handling for string-value attributes so they can use format strings + i.e. string interpolation. *) + +type std_tag = attr list -> node list -> node +(** A 'standard' tag with attributes and children. *) + +type void_tag = attr list -> node +(** A 'void element': + {: https://developer.mozilla.org/en-US/docs/Glossary/Void_element} with no + children. *) + +type 'a text_tag = attr list -> ('a, unit, string, node) format4 -> 'a +(** Tags which can have attributes but can contain only text. The text can be + formatted. *) + +val attr : string -> attr +(** [attr name] is a new attribute which does not carry any payload. E.g. + + {[let required = attr "required"]} + + @since 0.1.0. *) + +val string_attr : string -> ?raw:bool -> _ string_attr +(** [string_attr name fmt] is a new string-valued attribute which allows + formatting i.e. string interpolation of the value. Note, the [fmt] argument + is required due to the value restriction. + + @param raw (default [false]) whether to inject the raw text or to escape it. + Note that Dream does not support escaping inline JavaScript nor CSS, so + neither does dream-html: + {: https://github.com/aantron/dream/tree/master/example/7-template#security}. *) + +val uri_attr : string -> _ string_attr +(** Convenience for attributes whose values should be URIs. Takes care of both + URI-encoding and attribute escaping, as recommended in + {: https://cheatsheetseries.owasp.org/cheatsheets/Cross_Site_Scripting_Prevention_Cheat_Sheet.html#common-mistake}. + + Examples + + {[a [href "/blog?tags=iamsafe\"></a><script>alert('Pwned')</script>"] [txt "Tags: tag1 | tag2"] + ==> + <a href="/blog?tags=iamsafe%22%3E%3C/a%3E%3Cscript%3Ealert('Pwned')%3C/script%3E">Tags: tag1 | tag2</a> + + a [href "/foo?a=1&b=2 3&c=4<5&d=6>5"] [txt "Test"] + ==> + <a href="/foo?a=1&b=2%203&c=4%3C5&d=6%3E5">Test</a>]} *) + +val bool_attr : string -> bool to_attr +val float_attr : string -> float to_attr +val int_attr : string -> int to_attr +val std_tag : string -> std_tag +val void_tag : string -> void_tag + +val text_tag : string -> ?raw:bool -> _ text_tag +(** Build a tag which can contain only text. + + @param raw (default [false]) whether to inject the raw text or to escape it. + Note that Dream does not support escaping inline JavaScript nor CSS, so + neither does dream-html: + {: https://github.com/aantron/dream/tree/master/example/7-template#security}. *) + +val txt : ?raw:bool -> ('a, unit, string, node) format4 -> 'a +(** A text node inside the DOM e.g. the 'hi' in [<b>hi</b>]. Allows string + interpolation using the same formatting features as [Printf.sprintf]: + + {[b [] [txt "Hello, %s!" name]]} + + Or without interpolation: + + {[b [] [txt "Bold of you."]]} + + HTML-escapes the text value. You can use the [~raw] param to bypass escaping: + + {[let user_input = "<script>alert('I like HTML injection')</script>" in + txt ~raw:true "%s" user_input]} *) + +val comment : string -> node +(** A comment that will be embedded in the rendered HTML, i.e. [<!-- comment -->]. + The text is HTML-escaped. *) + + +(** {2 Accessors for tags} *) + +val ( +@ ) : node -> attr -> node +(** Add an attribute to a tag. + + {[let toast msg = p [id "toast"] [txt "%s" msg] + let toast_oob = toast "ok." +@ Hx.swap_oob "true"]} + + @raise Invalid_argument if the node is not a tag (i.e. if it is a text or + comment node). + @since 0.0.3. *) + +val ( -@ ) : node -> string -> node +(** Remove an attribute from a tag. + + @raise Invalid_argument if the node is not a tag (i.e. if it is a text or + comment node). + @since 0.0.3. *) + +val ( .@[] ) : node -> string -> string +(** Get the value of an existing attribute. + + {[let toast = p [id "toast"] [txt "OK."] + let toast_id = toast.@["id"]]} + + @raise Invalid_argument if the node is not a tag (i.e. if it is a text or + comment node). + @raise Not_found if the tag does not have the given attribute. + @since 0.0.3. *) + +val is_null : node -> bool +(** Get whether a node is null (empty) or not. Useful for conditional rendering + of UIs when you are passed in a node and you don't know if it's empty or not. + + @since 1.2.0. *) + +val is_null_ : attr -> bool +(** Get whether an attribute is null (empty) or not. + + @since 1.2.0. *) + +(** {2 Standard attributes and tags} *) + +(** All standard HTML attributes and tags. Some attributes and tags have the same + name, e.g. [style]. To disambiguate them, attributes have a [_] (underscore) + suffix. *) +module HTML : sig + (** {3 Attributes} + + Standard, most non-deprecated attributes from + {: https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes}. Where an + attribute name conflicts with an OCaml keyword, the name is suffixed with [_]. + Most attributes are constructed by passing in a value of some type. + + All string-valued attributes allow formatting (interpolation): + + {[div [id "section-%d" section_id] []]} + + Or plain strings: + + {[p [id "toast"] []]} + + Most boolean attributes are plain values and don't need to be constructed + with function calls: + + {[input [required]]} + + However, boolean attributes which may be inherited and toggled on/off in + children, are constructed by passing in a value: + + {[div [contenteditable true] [ + p [] [txt "Edit me!"]; + p [contenteditable false] [txt "Can't edit me!"]; + ]]} + + Enumerated attributes accept specific values: + + {[input [inputmode `tel]]} + + @since 1.0.0. *) + + type enctype = + [ `urlencoded + | `formdata + | `text_plain ] + + type method_ = + [ `GET + | `POST + | `dialog (** @since 2.1.0 *) ] + + val null_ : attr + (** An attribute that will not be rendered in the markup. Useful for conditional + logic where you sometimes want to render an attribute and sometimes not. + + {[p [if should_show then null_ else style_ "display:none"] [txt "Show and tell"]]} *) + + val accept : _ string_attr + val accept_charset : _ string_attr + val accesskey : _ string_attr + val action : _ string_attr + + val align : _ string_attr + [@@ocaml.deprecated + "See https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes"] + + val allow : _ string_attr + val alt : _ string_attr + val async : attr + + val autocapitalize : + [< `off | `none | `on | `sentences | `words | `characters] to_attr + + val autocomplete : + [< `off + | `on + | `name + | `honorific_prefix + | `given_name + | `additional_name + | `honorific_suffix + | `nickname + | `email + | `username + | `new_password + | `current_password + | `one_time_code + | `organization_title + | `organization + | `street_address + | `address_line1 + | `address_line2 + | `address_line3 + | `address_level4 + | `address_level3 + | `address_level2 + | `address_level1 + | `country + | `country_name + | `postal_code + | `cc_name + | `cc_given_name + | `cc_additional_name + | `cc_family_name + | `cc_number + | `cc_exp + | `cc_exp_month + | `cc_exp_year + | `cc_csc + | `cc_type + | `transaction_currency + | `transaction_amount + | `language + | `bday + | `bday_day + | `bday_month + | `bday_year + | `sex + | `tel + | `tel_country_code + | `tel_national + | `tel_area_code + | `tel_local + | `tel_extension + | `impp + | `url + | `photo + | `webauthn ] + to_attr + + val autofocus : attr + val autoplay : attr + val buffered : _ string_attr + val capture : [< `user | `environment] to_attr + val charset : _ string_attr + val checked : attr + val cite_ : _ string_attr + val class_ : _ string_attr + + val color : _ string_attr + [@@ocaml.deprecated + "See https://developer.mozilla.org/en-US/docs/Web/HTML/Element/font#color"] + + val cols : int to_attr + val colspan : int to_attr + val content : _ string_attr + val contenteditable : bool to_attr + val contextmenu : _ string_attr + val controls : attr + val coords : _ string_attr + val crossorigin : [< `anonymous | `use_credentials] to_attr + val data_ : _ string_attr + val datetime : _ string_attr + val decoding : [< `sync | `async | `auto] to_attr + val default : attr + val defer : attr + val dir : [< `ltr | `rtl | `auto] to_attr + val dirname : _ string_attr + val disabled : attr + val download : _ string_attr + val draggable : attr + val enctype : [< enctype] to_attr + + val fetchpriority : [< `high | `low | `auto] to_attr + (** @since 1.2.0. *) + + val for_ : _ string_attr + val form_ : _ string_attr + val formaction : _ string_attr + val formenctype : [< enctype] to_attr + val formmethod : [< method_] to_attr + val formnovalidate : attr + val formtarget : _ string_attr + val headers : _ string_attr + val height : _ string_attr + val hidden : [< `hidden | `until_found] to_attr + val high : float to_attr + val href : _ string_attr + val hreflang : _ string_attr + + val http_equiv : + [< `content_security_policy + | `content_type + | `default_style + | `x_ua_compatible + | `refresh ] + to_attr + + val id : _ string_attr + val integrity : _ string_attr + + val inputmode : + [< `none | `text | `decimal | `numeric | `tel | `search | `email | `url] + to_attr + + val ismap : attr + val itemprop : _ string_attr + + val kind : + [< `subtitles | `captions | `descriptions | `chapters | `metadata] to_attr + + val label_ : _ string_attr + val lang : _ string_attr + val list : _ string_attr + + val loading_lazy : attr + (** See {: https://developer.mozilla.org/en-US/docs/Web/HTML/Element/img#loading}. + [loading=eager] is the default so no need for specifically that value. + + @since 3.1.0. *) + + val loop : attr + val low : float to_attr + val max : _ string_attr + val maxlength : int to_attr + val media : _ string_attr + val method_ : [< method_] to_attr + val min : _ string_attr + val minlength : int to_attr + val multiple : attr + val muted : attr + val name : _ string_attr + val novalidate : attr + + val onblur : _ string_attr + (** Note that the value of this attribute is not escaped. *) + + val onclick : _ string_attr + (** Note that the value of this attribute is not escaped. *) + + val open_ : attr + val optimum : float to_attr + val pattern : _ string_attr + val ping : _ string_attr + val placeholder : _ string_attr + val playsinline : attr + val poster : _ string_attr + val preload : [< `none | `metadata | `auto] to_attr + val readonly : attr + + val referrerpolicy : + [< `no_referrer + | `no_referrer_when_downgrade + | `origin + | `origin_when_cross_origin + | `same_origin + | `strict_origin + | `strict_origin_when_cross_origin + | `unsafe_url ] + to_attr + + val rel : _ string_attr + val required : attr + val reversed : attr + + val role : + [ `alert + | `alertdialog + | `application + | `article + | `banner + | `button + | `cell + | `checkbox + | `columnheader + | `combobox (* command - do not use *) + | `comment + | `complementary (* composite - do not use *) + | `contentinfo + | `definition + | `dialog (* directory - deprecated *) + | `document + | `feed + | `figure + | `form + | `generic + | `grid + | `gridcell + | `group + | `heading + | `img + (* input - do not use *) + (* landmark - do not use *) + | `link + | `list + | `listbox + | `listitem + | `log + | `main + | `mark + | `marquee + | `math + | `menu + | `menubar + | `menuitem + | `menuitemcheckbox + | `menuitemradio + | `meter + | `navigation + | `none + | `note + | `option + | `presentation + | `progressbar + | `radio + | `radiogroup (* range - do not use *) + | `region (* roletype - do not use *) + | `row + | `rowgroup + | `rowheader + | `scrollbar + | `search + | `searchbox + | (* section - do not use *) + (* sectionhead - do not use *) + (* select - do not use *) + `separator + | `slider + | `spinbutton + | `status + | (* structure - do not use *) + `suggestion + | `switch + | `tab + | `table + | `tablist + | `tabpanel + | `term + | `textbox + | `timer + | `toolbar + | `tooltip + | `tree + | `treegrid + | `treeitem + (* widget - do not use *) + (* window - do not use *) ] + to_attr + (** @since 3.0.0 *) + + val rows : int to_attr + val rowspan : int to_attr + val sandbox : _ string_attr + val scope : _ string_attr + val selected : attr + val shape : _ string_attr + + val size : _ string_attr + (** Required for {: https://developer.mozilla.org/en-US/docs/Web/HTML/Element/select#size}. *) + + val sizes : _ string_attr + val slot_ : _ string_attr + val span_ : int to_attr + val spellcheck : bool to_attr + val src : _ string_attr + val srcdoc : _ string_attr + val srclang : _ string_attr + val srcset : _ string_attr + val start : int to_attr + val step : _ string_attr + + val style_ : _ string_attr + (** Note that the value of this attribute is not escaped. *) + + val tabindex : int to_attr + val target : _ string_attr + val title_ : _ string_attr + val translate : [< `yes | `no] to_attr + + val type_ : _ string_attr + (** Note: this can't be restricted to just the allowed values for [<input type>], + because it's used in other elements e.g. [<link type>]. *) + + val usemap : _ string_attr + val value : _ string_attr + val width : _ string_attr + val wrap : [< `hard | `soft] to_attr + + (** {3 Tags} + + HTML tags. Most (standard tags) are constructed by passing a list of + attributes and a list of children: + + {[div [id "my-div"] [p [] [txt "Hello"]]]} + + Some (void elements) are constructed only with a list of attributes: + + {[input [required; type_ "email"; name "email-addr"]]} + + Finally, a few (text elements) are constructed with a list of attributes + and a single format string child: + + {[title [] "Document title" + + title [] "My App ・ %s" page_name + + script [] {|alert('Careful, this is not escaped :-)');|} + ]} *) + + val null : node list -> node + (** A tag that will not be rendered in the markup. Useful for containing a bunch + of child nodes inside a single node without having to litter the DOM with an + actual node. Also may be called 'splicing'. + + {[null [ + p [] [txt "This paragraph."]; + p [] [txt "And this paragraph."]; + p [] [txt "Are spliced directly into the document without a containing node."]; + ]]} + + Also useful for constructing a completely empty node that is erased when + printing: {[null []]} *) + + val a : std_tag + val address : std_tag + val area : void_tag + val abbr : std_tag + val article : std_tag + val aside : std_tag + val audio : std_tag + val b : std_tag + val base : void_tag + val bdi : std_tag + val bdo : std_tag + val blockquote : std_tag + val body : std_tag + val br : void_tag + val button : std_tag + val canvas : std_tag + val caption : std_tag + val cite : std_tag + val code : std_tag + val col : void_tag + val colgroup : std_tag + val data : std_tag + val datalist : std_tag + val dd : std_tag + val del : std_tag + val details : std_tag + val dfn : std_tag + val dialog : std_tag + val div : std_tag + val dl : std_tag + val dt : std_tag + val em : std_tag + val embed : void_tag + val fieldset : std_tag + val figcaption : std_tag + val figure : std_tag + val form : std_tag + val footer : std_tag + val h1 : std_tag + val h2 : std_tag + val h3 : std_tag + val h4 : std_tag + val h5 : std_tag + val h6 : std_tag + val head : std_tag + val header : std_tag + val hgroup : std_tag + val hr : void_tag + + val html : std_tag + (** A [<!DOCTYPE html>] declaration is automatically prefixed when this tag is + printed. *) + + val i : std_tag + val iframe : std_tag + val img : void_tag + val input : void_tag + val ins : std_tag + val kbd : std_tag + val label : std_tag + val legend : std_tag + val li : std_tag + val link : void_tag + val main : std_tag + val map : std_tag + val mark : std_tag + val menu : std_tag + val meta : void_tag + val meter : std_tag + val nav : std_tag + val noscript : std_tag + val object_ : std_tag + val ol : std_tag + val optgroup : std_tag + val option : _ text_tag + val output : std_tag + val p : std_tag + val picture : std_tag + val pre : std_tag + val progress : std_tag + val q : std_tag + val rp : std_tag + val rt : std_tag + val ruby : std_tag + val s : std_tag + val samp : std_tag + + val script : _ text_tag + (** Note that the content of this tag is not escaped. *) + + val section : std_tag + val select : std_tag + val slot : std_tag + val small : std_tag + val source : void_tag + val span : std_tag + val strong : std_tag + + val style : _ text_tag + (** Note that the content of this tag is not escaped. *) + + val sub : std_tag + val summary : std_tag + val sup : std_tag + val table : std_tag + val tbody : std_tag + val td : std_tag + val template : std_tag + val textarea : _ text_tag + val tfoot : std_tag + val th : std_tag + val thead : std_tag + val time : std_tag + val title : _ text_tag + val tr : std_tag + val track : void_tag + val u : std_tag + val ul : std_tag + val var : std_tag + val video : std_tag + val wbr : void_tag +end + +(** @since 1.1.0. *) +module SVG : sig + val d : _ string_attr + val fill : _ string_attr + val stroke : _ string_attr + val stroke_linecap : [< `butt | `round | `square] to_attr + + val stroke_linejoin : + [< `arcs | `bevel | `miter | `miter_clip | `round] to_attr + + val stroke_width : _ string_attr + val viewbox : min_x:int -> min_y:int -> width:int -> height:int -> attr + val xmlns : attr + val path : std_tag + val svg : std_tag +end + +(** @since 3.1.0. *) +module MathML : sig + val accent : bool to_attr + val accentunder : bool to_attr + val columnspan : int to_attr + val depth : _ string_attr + val dir : [`ltr | `rtl] to_attr + + val display_block : attr + (** See {: https://developer.mozilla.org/en-US/docs/Web/MathML/Element/math#display}. + [display=inline] is the default, so there is no need to bind its value. *) + + val displaystyle : bool to_attr + val fence : bool to_attr + val height : _ string_attr + val largeop : bool to_attr + val linethickness : _ string_attr + val lspace : _ string_attr + val mathvariant : _ string_attr + val maxsize : _ string_attr + val minsize : _ string_attr + val movablelimits : bool to_attr + val rowspan : int to_attr + val rspace : _ string_attr + val scriptlevel : _ string_attr + val separator : bool to_attr + val stretchy : bool to_attr + val symmetric : bool to_attr + val voffset : _ string_attr + val xmlns : attr + val annotation : std_tag + val annotation_xml : std_tag + val math : std_tag + val merror : std_tag + val mfrac : std_tag + val mi : std_tag + val mmultiscripts : std_tag + val mn : std_tag + val mo : std_tag + val mover : std_tag + val mpadded : std_tag + val mphantom : std_tag + val mroot : std_tag + val mrow : std_tag + val ms : std_tag + val mspace : std_tag + val msqrt : std_tag + val mstyle : std_tag + val msub : std_tag + val msubsup : std_tag + val msup : std_tag + val mtable : std_tag + val mtd : std_tag + val mtext : std_tag + val mtr : std_tag + val munder : std_tag + val munderover : std_tag + val semantics : std_tag +end + +(** {2 ARIA support} *) + +(** {: https://developer.mozilla.org/en-US/docs/Web/Accessibility/ARIA/Attributes/} + + @since 3.0.0. *) +module Aria : sig + val activedescendant : _ string_attr + val atomic : attr + val autocomplete : [`inline | `list | `both] to_attr + val braillelabel : _ string_attr + val brailleroledescription : _ string_attr + val busy : attr + val checked : [`false_ | `true_ | `mixed] to_attr + val colcount : int to_attr + val colindextext : _ string_attr + val colspan : int to_attr + val controls : _ string_attr + val current : [`page | `step | `location | `date | `time | `true_] to_attr + val describedby : _ string_attr + val description : _ string_attr + val details : _ string_attr + val disabled : attr + val errormessage : _ string_attr + val expanded : bool to_attr + val flowto : _ string_attr + val haspopup : [`true_ | `menu | `listbox | `tree | `grid | `dialog] to_attr + val hidden : bool to_attr + val invalid : [`grammar | `spelling | `true_] to_attr + val keyshortcuts : _ string_attr + val label : _ string_attr + val labelledby : _ string_attr + val level : int to_attr + val live : [`assertive | `polite] to_attr + val modal : attr + val multiline : attr + val multiselectable : attr + val orientation : [`horizontal | `vertical] to_attr + val owns : _ string_attr + val placeholder : _ string_attr + val posinset : int to_attr + val pressed : [`false_ | `mixed | `true_] to_attr + val readonly : attr + val relevant : [`additions | `all | `removals | `text] to_attr + val required : attr + val roledescription : _ string_attr + val rowcount : int to_attr + val rowindex : int to_attr + val rowindextext : _ string_attr + val rowspan : int to_attr + val selected : bool to_attr + val setsize : int to_attr + val sort : [`ascending | `descending | `other] to_attr + val valuemax : float to_attr + val valuemin : float to_attr + val valuenow : float to_attr + val valuetext : _ string_attr +end + +(** {2 htmx support} *) + +(** htmx support {: https://htmx.org/reference/} *) +module Hx : sig + val __ : _ string_attr + (** This attribute serves as the _ attribute, which is used by Hyperscript. + Note that the value of this attribute is not escaped. + + @since 0.1.0. *) + + val boost : bool to_attr + val confirm : _ string_attr + val delete : _ string_attr + val disable : attr + val disinherit : _ string_attr + + val encoding_formdata : attr + (** Hardcoding of the [hx-encoding] attribute to [multipart/form-data]. *) + + val ext : _ string_attr + val get : _ string_attr + val headers : _ string_attr + + val history_false : attr + (** Hardcoding of the [hx-history] attribute to [false]. *) + + val history_elt : attr + val include_ : _ string_attr + + val indicator : _ string_attr + (** Note that the value of this attribute is not escaped as it may include a + CSS selector. *) + + val on : _ string_attr + [@@ocaml.deprecated "See https://htmx.org/attributes/hx-on/#hx-on-deprecated"] + (** Note that the value of this attribute is not escaped. *) + + val on_ : event:string -> _ string_attr + (** The [hx-on:*] set of attributes, where [*] represents DOM events: + {: https://htmx.org/attributes/hx-on/}. + + Note that the value of this attribute is not escaped. + + @since 2.1.0. *) + + val params : _ string_attr + val patch : _ string_attr + val post : _ string_attr + + val preload : attr + (** The preload extension: {: https://htmx.org/extensions/preload/} *) + + val preserve : attr + val prompt : _ string_attr + val push_url : _ string_attr + val put : _ string_attr + val replace_url : _ string_attr + val request : _ string_attr + + val select : _ string_attr + (** Note that the value of this attribute is not escaped as it may include a + CSS selector. *) + + val select_oob : _ string_attr + (** Note that the value of this attribute is not escaped as it may include a + CSS selector. *) + + val sse_connect : _ string_attr + val sse_swap : _ string_attr + + val swap : _ string_attr + (** Note that the value of this attribute is not escaped as it may include a + CSS selector. *) + + val swap_oob : _ string_attr + (** Note that the value of this attribute is not escaped as it may include a + CSS selector. *) + + val sync : _ string_attr + + val target : _ string_attr + (** Note that the value of this attribute is not escaped as it may include a + CSS selector. *) + + val trigger : _ string_attr + (** Note that the value of this attribute is not escaped. *) + + val validate : attr + val vals : _ string_attr + val ws_connect : _ string_attr + val ws_send : attr +end diff --git a/lib/render/Render_dream.ml b/lib/render/Render_dream.ml index 21d77d9..83ccd05 100644 --- a/lib/render/Render_dream.ml +++ b/lib/render/Render_dream.ml @@ -1,7 +1,7 @@ open Core open Prelude -open Dream_html +open Dream_html_lite module E = Render_effect.Perform module F = Dream_forester diff --git a/lib/render/dune b/lib/render/dune index 7e3bc4a..991a292 100644 --- a/lib/render/dune +++ b/lib/render/dune @@ -2,7 +2,7 @@ (name Render) (preprocess (pps ppx_deriving.show)) - (libraries forester.prelude forester.core asai algaeff dream-html yojson) + (libraries forester.prelude forester.core asai algaeff yojson) (public_name forester.render)) (env diff --git a/test/dune b/test/dune index b66589c..8a8089b 100644 --- a/test/dune +++ b/test/dune @@ -1,3 +1,3 @@ (tests (names parse store) - (libraries forester.frontend irmin.unix)) + (libraries forester.frontend irmin.unix lwt.unix)) -- 2.45.2