From 8ed04489e19d4693e9c96b88313f34a840d41190 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 9 Jan 2019 20:15:34 -0400 Subject: Expanded HTML machinery. --- stdlib/source/lux/data/format/html.lux | 317 +++++++++++++++++++++++--- stdlib/source/lux/world/net/http.lux | 6 +- stdlib/source/lux/world/net/http/response.lux | 11 + 3 files changed, 293 insertions(+), 41 deletions(-) (limited to 'stdlib/source') diff --git a/stdlib/source/lux/data/format/html.lux b/stdlib/source/lux/data/format/html.lux index 45a7117ad..b260a8768 100644 --- a/stdlib/source/lux/data/format/html.lux +++ b/stdlib/source/lux/data/format/html.lux @@ -1,53 +1,294 @@ (.module: - [lux (#- comment) + [lux (#- Meta comment and) [data + ["." maybe] ["." text format] - [collection [list ("list/." Functor)]]]]) + [collection + [list ("list/." Functor)]]] + [type + abstract] + [world + [net (#+ URL)]]] + [// + ["." css (#+ CSS)]]) + +(type: #export Tag Text) + +(type: #export ID Text) (type: #export Attributes {#.doc "Attributes for an HTML tag."} (List [Text Text])) -(type: #export HTML Text) +(type: #export Script Text) + +(type: #export Target + #Blank + #Parent + #Self + #Top + (#Frame Text)) -(def: #export (text value) +(def: (target value) + (-> Target Text) + (case value + #Blank "_blank" + #Parent "_parent" + #Self "_self" + #Top "_top" + (#Frame name) name)) + +(def: sanitize {#.doc "Properly formats text to ensure no injection can happen on the HTML."} - (-> Text HTML) - (|> value - (text.replace-all "&" "&") - (text.replace-all "<" "<") - (text.replace-all ">" ">") - (text.replace-all text.double-quote """) - (text.replace-all "'" "'") - (text.replace-all "/" "/"))) - -(def: #export (comment content) - (-> Text HTML) - (format "")) - -(def: attrs-to-text + (-> Text Text) + (|>> (text.replace-all "&" "&") + (text.replace-all "<" "<") + (text.replace-all ">" ">") + (text.replace-all text.double-quote """) + (text.replace-all "'" "'") + (text.replace-all "/" "/"))) + +(def: attributes (-> Attributes Text) - (|>> (list/map (function (_ [key val]) (format key "=" text.double-quote (text val) text.double-quote))) + (|>> (list/map (function (_ [key val]) + (format key "=" text.double-quote (..sanitize val) text.double-quote))) (text.join-with " "))) -(def: #export (tag name attrs children) - {#.doc "Generates the HTML for a tag."} - (-> Text Attributes (List HTML) HTML) - (format "<" name " " (attrs-to-text attrs) ">" - (text.join-with " " children) - "")) - -(do-template [ ] - [(def: #export - (-> HTML HTML) - (let [doc-type ] - (function (_ document) - (format doc-type - document))))] - - [html-5 ""] - [html-4_01 (format "")] - [xhtml-1_0 (format "")] - [xhtml-1_1 (format "")] +(def: (open tag attributes) + (-> Tag Attributes Text) + (|> attributes + ..attributes + (format tag " ") + (text.enclose ["<" ">"]))) + +(def: close + (-> Tag Text) + (text.enclose [""])) + +(abstract: #export (HTML kind) + {} + + Text + + (do-template [ ] + [(abstract: #export {} Any) + (type: #export (HTML ))] + + [Meta Meta'] + [Head Head'] + [Item Item'] + [Option Option'] + [Input Input'] + [Body Body'] + [Document Document'] + ) + + (abstract: #export (Element' brand) {} Any) + (type: #export Element (HTML (Element' Any))) + + (abstract: #export Content' {} Any) + (type: #export Content (HTML (Element' Content'))) + + (def: #export html + (-> (HTML Any) Text) + (|>> :representation)) + + (def: #export (and pre post) + (All [kind] (-> (HTML kind) (HTML kind) (HTML kind))) + (:abstraction (format (:representation pre) (:representation post)))) + + (def: #export (comment content node) + (All [brand] (-> Text (HTML brand) (HTML brand))) + (:abstraction + (format (text.enclose [""] content) + (:representation node)))) + + (def: (tag name) + (-> Tag (-> Attributes (HTML Any) HTML)) + (function (_ attributes content) + (:abstraction + (format (..open name attributes) + (:representation content) + (..close name))))) + + (do-template [ ] + [(def: #export + (-> Attributes Meta) + (|>> (..open ) + :abstraction))] + + [link "link"] + [meta "meta"] + ) + + (def: #export (base href target) + (-> URL (Maybe Target) Meta) + (let [partial (list ["href" href]) + full (case target + (#.Some target) + (list& ["target" (..target target)] partial) + + #.None + partial)] + (:abstraction (..open "base" full)))) + + (do-template [ ] + [(def: #export ( content) + (-> Text Meta) + (:abstraction + (format (..open (list)) + content + (..close ))))] + + [title "title"] + [no-script "noscript"] + ) + + (def: #export (style css) + (-> CSS Meta) + (:abstraction + (format (..open "style" (list)) + css + (..close "style")))) + + (def: #export (script attributes inline) + (-> Attributes (Maybe Script) Meta) + (:abstraction + (format (..open "script" attributes) + (maybe.default "" inline) + (..close "script")))) + + (def: #export text + (-> Text Content) + (|>> ..sanitize + :abstraction)) + + (do-template [ ] + [(def: #export + Element + (:abstraction (..open (list)))) + + (def: #export )] + ["br" br break] + ["hr" hr separator] + ) + + (def: #export (image source attributes) + (-> URL Attributes Element) + (|> attributes + (#.Cons ["src" source]) + (..open "img") + :abstraction)) + + (def: #export (anchor href attributes content) + (-> URL Attributes Element Element) + (..tag "a" (list& ["href" href] attributes) content)) + + (def: #export (input attributes) + (-> Attributes Input) + (|> attributes + (..open "input") + :abstraction)) + + (def: #export (label for) + (-> ID Input) + (:abstraction + (format (..open "label" (list ["for" for])) + (..close "label")))) + + (type: #export Phrase (-> Attributes Content Element)) + + (type: #export Composite (-> Attributes Element Element)) + + (def: #export (phrase tag) + (-> Tag Phrase) + (function (_ attributes content) + (:abstraction + (format (..open tag attributes) + (:representation content) + (..close tag))))) + + (do-template [ ] + [(def: #export + Phrase + (..phrase ))] + + [block-quote "blockquote"] + [bold "b"] + [cite "cite"] + [code "code"] + [definition "dfn"] + [emphasized "em"] + [italic "i"] + [keyboard "kbd"] + [marked "mark"] + [pre "pre"] + [quote "q"] + [sample "samp"] + [strong "strong"] + [variable "var"] + ) + + (def: #export (composite tag) + (-> Tag Composite) + (function (_ attributes content) + (:abstraction + (format (..open tag attributes) + (:representation content) + (..close tag))))) + + (do-template [ ] + [(def: #export + Composite + (..composite ))] + + [div "div"] + [footer "footer"] + [header "header"] + [paragraph "p"] + [section "section"] + [span "span"] + ) + + (def: #export p ..paragraph) + + (do-template [ ] + [(def: #export + (-> Attributes ) + (..tag ))] + + [button "button" Element Input] + [item "li" (HTML Any) Item] + [ordered "ol" Item Element] + [unordered "ul" Item Element] + [option "option" Content Option] + [data-list "datalist" Option Element] + [select "select" Option Input] + ) + + (do-template [ ] + [(def: #export + (-> ) + (..tag (list)))] + + [head "head" Meta Head] + [body "body" Element Body] + ) + + (do-template [ ] + [(def: #export + (-> Head Body Document) + (let [doc-type ] + (function (_ head body) + (|> (..tag "html" (list) (..and head body)) + :representation + (format doc-type) + :abstraction))))] + + [html-5 ""] + [html-4_01 (format "")] + [xhtml-1_0 (format "")] + [xhtml-1_1 (format "")] + ) ) diff --git a/stdlib/source/lux/world/net/http.lux b/stdlib/source/lux/world/net/http.lux index 04e7ef829..b518858a6 100644 --- a/stdlib/source/lux/world/net/http.lux +++ b/stdlib/source/lux/world/net/http.lux @@ -62,15 +62,15 @@ #query Context #form (Maybe Context)}) -(type: #export Payload +(type: #export Message {#headers Context #body Body}) (type: #export Request - [Identification Protocol Resource Payload]) + [Identification Protocol Resource Message]) (type: #export Response - [Status Payload]) + [Status Message]) (type: #export Server (-> Request (Promise Response))) diff --git a/stdlib/source/lux/world/net/http/response.lux b/stdlib/source/lux/world/net/http/response.lux index fc23dfd20..624b0167c 100644 --- a/stdlib/source/lux/world/net/http/response.lux +++ b/stdlib/source/lux/world/net/http/response.lux @@ -7,6 +7,8 @@ ["." text format ["." encoding]] + [format + ["." html (#+ HTML)]] [collection ["." array] ["." dictionary (#+ Dictionary)]]] @@ -53,3 +55,12 @@ (header.content-length (binary.size data)) (header.content-type mime.text)) #//.body (channel/wrap data)}])) + +(def: #export (html content) + (-> (HTML Any) Response) + (let [data (encoding.to-utf8 (html.html content))] + [status.ok + {#//.headers (|> (dictionary.new text.Hash) + (header.content-length (binary.size data)) + (header.content-type mime.html)) + #//.body (channel/wrap data)}])) -- cgit v1.2.3