diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-12 00:13:02 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-12 00:13:02 +0200 |
commit | da8d1467dff8b27af7a3ae649d92ead5cbf704d8 (patch) | |
tree | cd4231abb8ec24d79dd3a4a8b5e563ee2bb82219 | |
parent | Add number of TODO's. (diff) | |
parent | Handle error for user-additions salar. (diff) | |
download | calp-da8d1467dff8b27af7a3ae649d92ead5cbf704d8.tar.gz calp-da8d1467dff8b27af7a3ae649d92ead5cbf704d8.tar.xz |
Allow HTML output of all routes.
XHTML is still the far supperior format. However; Chrome(-like) browsers
Lighthouse feature is worth quite a bit when it comes to ensuring a good
web page, and Lighthouse refuses to work on anything except text/html.
This is my work-around for that.
-rw-r--r-- | module/calp/html/components.scm | 1 | ||||
-rw-r--r-- | module/calp/html/view/calendar.scm | 7 | ||||
-rw-r--r-- | module/calp/html/view/calendar/month.scm | 2 | ||||
-rw-r--r-- | module/calp/html/view/calendar/week.scm | 2 | ||||
-rw-r--r-- | module/calp/server/routes.scm | 68 | ||||
-rw-r--r-- | module/sxml/html.scm | 379 | ||||
-rw-r--r-- | static/components/vevent.ts | 2 | ||||
-rw-r--r-- | static/globals.ts | 2 | ||||
-rw-r--r-- | static/user/user-additions.js | 13 | ||||
-rw-r--r-- | static/vevent.ts | 10 | ||||
-rw-r--r-- | tests/test/html/component.scm | 17 |
11 files changed, 440 insertions, 63 deletions
diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index 9b3e4ce0..6ff59502 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -12,6 +12,7 @@ ((_ (@ attr ...) body ...) `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + ,(lambda () (format #t "~%<!DOCTYPE html>~%")) (html (@ (xmlns "http://www.w3.org/1999/xhtml") attr ...) body ...))) ((_ body ...) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 6945c5d2..dd94dc16 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -102,12 +102,11 @@ (content ,(date->string (date+ end-date (date day: 1)) "~s")))) (script - ,(format #f - " + ,(lambda () (format #t " EDIT_MODE=~:[false~;true~]; window.default_calendar='~a';" - (edit-mode) - (base64encode ((@ (vcomponent) default-calendar))))) + (edit-mode) + (base64encode ((@ (vcomponent) default-calendar)))))) (style ,(format #f "html { diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index 2b4c888a..205d6049 100644 --- a/module/calp/html/view/calendar/month.scm +++ b/module/calp/html/view/calendar/month.scm @@ -35,7 +35,7 @@ (events-between s e (list->stream long-events))))) (date-range pre-start post-end (date day: 7)))) - `((script "window.VIEW='month';") + `((script ,(lambda () (format #t "window.VIEW='month';"))) (header (@ (class "table-head")) ,(string-titlecase (date->string start-date "~B ~Y"))) (div (@ (class "caltable") diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 16337102..b68184f9 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -27,7 +27,7 @@ (define*-public (render-calendar key: calendars events start-date end-date #:allow-other-keys) (let* ((long-events short-events (partition long-event? (stream->list (events-between start-date end-date events)))) (range (date-range start-date end-date))) - `((script "window.VIEW='week';") + `((script ,(lambda () (format #t "window.VIEW='week';"))) (div (@ (class "calendar")) (div (@ (class "days")) ;; Top left area diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 896219cd..762681d9 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -13,7 +13,8 @@ :use-module ((web uri) :select (build-relative-ref)) :use-module ((web uri-query) :select (encode-query-parameters)) - :use-module (sxml simple) + :use-module ((sxml simple) :select (sxml->xml xml->sxml)) + :use-module ((sxml html) :select (sxml->html)) :use-module (sxml xpath) :use-module (sxml namespace) @@ -37,13 +38,17 @@ :use-module (calp translation) + :use-module ((calp html components) :select (xhtml-doc include-css)) + ) -(define (sxml->html-string sxml) - (with-output-to-string - (lambda () (display "<!doctype html>\n") (sxml->xml sxml)))) +(define (content-type html?) + (if html? 'text/html 'application/xhtml+xml)) + +(define (sxml->output html?) + (if html? sxml->html sxml->xml)) @@ -118,6 +123,7 @@ (define ical-namespace '(IC . "urn:ietf:params:xml:ns:icalendar-2.0")) +(define root-script "window.onload = () => document.getElementsByTagName('a')[0].click()") ;; TODO ensure encoding on all fields which take user provided data. ;; Possibly a fallback which strips everything unknown, and treats @@ -127,12 +133,14 @@ ;; Manual redirect to not reserve root. ;; Also reason for really ugly frontend redirect. - (GET "/" () - (return '((content-type text/html)) - (sxml->html-string - `(body (a (@ (href "/today")) ,(_ "Go to Today")) - (script "window.onload = function() { - document.getElementsByTagName('a')[0].click();}"))))) + (GET "/" (html) + (return `((content-type ,(content-type html))) + (with-output-to-string + (lambda () + ((sxml->output html) + (xhtml-doc + (body (a (@ (href "/today")) ,(_ "Go to Today")) + (script ,(lambda () (display root-script)))))))))) (GET "/favicon.ico" () (return @@ -141,14 +149,12 @@ ;; TODO any exception in this causes the whole page to fail ;; It would be much better if most of the page could still make it. - (GET "/week/:start-date.html" (start-date) - (let* ((start-date - (start-of-week (parse-iso-date start-date)))) - - (return `((content-type application/xhtml+xml)) + (GET "/week/:start-date.html" (start-date html) + (let* ((start-date (start-of-week (parse-iso-date start-date)))) + (return `((content-type ,(content-type html))) (with-output-to-string (lambda () - (sxml->xml + ((sxml->output html) (html-generate calendars: (get-calendars global-event-object) events: (get-event-set global-event-object) start-date: start-date @@ -159,13 +165,12 @@ intervaltype: 'week ))))))) - (GET "/month/:start-date.html" (start-date) + (GET "/month/:start-date.html" (start-date html) (let* ((start-date (start-of-month (parse-iso-date start-date)))) - - (return '((content-type application/xhtml+xml)) + (return `((content-type ,(content-type html))) (with-output-to-string (lambda () - (sxml->xml + ((sxml->output html) (html-generate calendars: (get-calendars global-event-object) events: (get-event-set global-event-object) start-date: start-date @@ -355,7 +360,7 @@ (prop event 'SUMMARY))))) )))))) - (GET "/search" (q p onlyfuture) + (GET "/search" (q p onlyfuture html) (define search-term (if (and q (not (string-null? q))) (if onlyfuture @@ -397,10 +402,10 @@ (set! error (format #f "~?~%" fmt arg)))))) - (return '((content-type application/xhtml+xml)) + (return `((content-type (content-type html))) (with-output-to-string (lambda () - (sxml->xml + ((sxml->output html) (search-result-page error (and=> q (negate string-null?)) @@ -433,16 +438,19 @@ (scm-error err proc fmt fmt-args data))))) ;; Note that `path' will most likely start with a slash - (GET "/static:path{.*}" (path) + (GET "/static:path{.*}" (path html) (catch 'misc-error (lambda () (return - '((content-type text/html)) - (sxml->html-string - `(html - (head (title ,(_ "Calp directory listing for ") path) - ,((@ (calp html components) include-css) "/static/directory-listing.css")) - (body ,(directory-table (static-dir) path)))))) + `((content-type ,(content-type html))) + (with-output-to-string + (lambda () + ((sxml->output html) + (xhtml-doc + (head (title ,(_ "Calp directory listing for ") path) + ,(include-css + "/static/directory-listing.css")) + (body ,(directory-table (static-dir) path)))))))) (lambda (err proc fmt fmt-args data) (return (build-response code: 404) (format #f "~?" fmt fmt-args))))) diff --git a/module/sxml/html.scm b/module/sxml/html.scm new file mode 100644 index 00000000..473cfd9e --- /dev/null +++ b/module/sxml/html.scm @@ -0,0 +1,379 @@ +;; Copyright © 2015 David Thompson <davet@gnu.org> +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3 of +;; the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library. If not, see +;; <http://www.gnu.org/licenses/>. + +;; https://dthompson.us/rendering-html-with-sxml-and-gnu-guile.html + +(define-module (sxml html) + #:use-module (sxml simple) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 hash-table) + #:export (sxml->html)) + +(define %void-elements + '(area + base + br + col + command + embed + hr + img + input + keygen + link + meta + param + source + track + wbr)) + +(define (void-element? tag) + "Return #t if TAG is a void element." + (pair? (memq tag %void-elements))) + +(define %escape-chars + (alist->hash-table + '((#\" . "quot") + (#\& . "amp") + (#\' . "apos") + (#\< . "lt") + (#\> . "gt") + (#\¡ . "iexcl") + (#\¢ . "cent") + (#\£ . "pound") + (#\¤ . "curren") + (#\¥ . "yen") + (#\¦ . "brvbar") + (#\§ . "sect") + (#\¨ . "uml") + (#\© . "copy") + (#\ª . "ordf") + (#\« . "laquo") + (#\¬ . "not") + (#\® . "reg") + (#\¯ . "macr") + (#\° . "deg") + (#\± . "plusmn") + (#\² . "sup2") + (#\³ . "sup3") + (#\´ . "acute") + (#\µ . "micro") + (#\¶ . "para") + (#\· . "middot") + (#\¸ . "cedil") + (#\¹ . "sup1") + (#\º . "ordm") + (#\» . "raquo") + (#\¼ . "frac14") + (#\½ . "frac12") + (#\¾ . "frac34") + (#\¿ . "iquest") + (#\À . "Agrave") + (#\Á . "Aacute") + (#\ . "Acirc") + (#\à . "Atilde") + (#\Ä . "Auml") + (#\Å . "Aring") + (#\Æ . "AElig") + (#\Ç . "Ccedil") + (#\È . "Egrave") + (#\É . "Eacute") + (#\Ê . "Ecirc") + (#\Ë . "Euml") + (#\Ì . "Igrave") + (#\Í . "Iacute") + (#\Î . "Icirc") + (#\Ï . "Iuml") + (#\Ð . "ETH") + (#\Ñ . "Ntilde") + (#\Ò . "Ograve") + (#\Ó . "Oacute") + (#\Ô . "Ocirc") + (#\Õ . "Otilde") + (#\Ö . "Ouml") + (#\× . "times") + (#\Ø . "Oslash") + (#\Ù . "Ugrave") + (#\Ú . "Uacute") + (#\Û . "Ucirc") + (#\Ü . "Uuml") + (#\Ý . "Yacute") + (#\Þ . "THORN") + (#\ß . "szlig") + (#\à . "agrave") + (#\á . "aacute") + (#\â . "acirc") + (#\ã . "atilde") + (#\ä . "auml") + (#\å . "aring") + (#\æ . "aelig") + (#\ç . "ccedil") + (#\è . "egrave") + (#\é . "eacute") + (#\ê . "ecirc") + (#\ë . "euml") + (#\ì . "igrave") + (#\í . "iacute") + (#\î . "icirc") + (#\ï . "iuml") + (#\ð . "eth") + (#\ñ . "ntilde") + (#\ò . "ograve") + (#\ó . "oacute") + (#\ô . "ocirc") + (#\õ . "otilde") + (#\ö . "ouml") + (#\÷ . "divide") + (#\ø . "oslash") + (#\ù . "ugrave") + (#\ú . "uacute") + (#\û . "ucirc") + (#\ü . "uuml") + (#\ý . "yacute") + (#\þ . "thorn") + (#\ÿ . "yuml") + (#\Œ . "OElig") + (#\œ . "oelig") + (#\Š . "Scaron") + (#\š . "scaron") + (#\Ÿ . "Yuml") + (#\ƒ . "fnof") + (#\ˆ . "circ") + (#\˜ . "tilde") + (#\Α . "Alpha") + (#\Β . "Beta") + (#\Γ . "Gamma") + (#\Δ . "Delta") + (#\Ε . "Epsilon") + (#\Ζ . "Zeta") + (#\Η . "Eta") + (#\Θ . "Theta") + (#\Ι . "Iota") + (#\Κ . "Kappa") + (#\Λ . "Lambda") + (#\Μ . "Mu") + (#\Ν . "Nu") + (#\Ξ . "Xi") + (#\Ο . "Omicron") + (#\Π . "Pi") + (#\Ρ . "Rho") + (#\Σ . "Sigma") + (#\Τ . "Tau") + (#\Υ . "Upsilon") + (#\Φ . "Phi") + (#\Χ . "Chi") + (#\Ψ . "Psi") + (#\Ω . "Omega") + (#\α . "alpha") + (#\β . "beta") + (#\γ . "gamma") + (#\δ . "delta") + (#\ε . "epsilon") + (#\ζ . "zeta") + (#\η . "eta") + (#\θ . "theta") + (#\ι . "iota") + (#\κ . "kappa") + (#\λ . "lambda") + (#\μ . "mu") + (#\ν . "nu") + (#\ξ . "xi") + (#\ο . "omicron") + (#\π . "pi") + (#\ρ . "rho") + (#\ς . "sigmaf") + (#\σ . "sigma") + (#\τ . "tau") + (#\υ . "upsilon") + (#\φ . "phi") + (#\χ . "chi") + (#\ψ . "psi") + (#\ω . "omega") + (#\ϑ . "thetasym") + (#\ϒ . "upsih") + (#\ϖ . "piv") + (#\ . "ensp") + (#\ . "emsp") + (#\ . "thinsp") + (#\– . "ndash") + (#\— . "mdash") + (#\‘ . "lsquo") + (#\’ . "rsquo") + (#\‚ . "sbquo") + (#\“ . "ldquo") + (#\” . "rdquo") + (#\„ . "bdquo") + (#\† . "dagger") + (#\‡ . "Dagger") + (#\• . "bull") + (#\… . "hellip") + (#\‰ . "permil") + (#\′ . "prime") + (#\″ . "Prime") + (#\‹ . "lsaquo") + (#\› . "rsaquo") + (#\‾ . "oline") + (#\⁄ . "frasl") + (#\€ . "euro") + (#\ℑ . "image") + (#\℘ . "weierp") + (#\ℜ . "real") + (#\™ . "trade") + (#\ℵ . "alefsym") + (#\← . "larr") + (#\↑ . "uarr") + (#\→ . "rarr") + (#\↓ . "darr") + (#\↔ . "harr") + (#\↵ . "crarr") + (#\⇐ . "lArr") + (#\⇑ . "uArr") + (#\⇒ . "rArr") + (#\⇓ . "dArr") + (#\⇔ . "hArr") + (#\∀ . "forall") + (#\∂ . "part") + (#\∃ . "exist") + (#\∅ . "empty") + (#\∇ . "nabla") + (#\∈ . "isin") + (#\∉ . "notin") + (#\∋ . "ni") + (#\∏ . "prod") + (#\∑ . "sum") + (#\− . "minus") + (#\∗ . "lowast") + (#\√ . "radic") + (#\∝ . "prop") + (#\∞ . "infin") + (#\∠ . "ang") + (#\∧ . "and") + (#\∨ . "or") + (#\∩ . "cap") + (#\∪ . "cup") + (#\∫ . "int") + (#\∴ . "there4") + (#\∼ . "sim") + (#\≅ . "cong") + (#\≈ . "asymp") + (#\≠ . "ne") + (#\≡ . "equiv") + (#\≤ . "le") + (#\≥ . "ge") + (#\⊂ . "sub") + (#\⊃ . "sup") + (#\⊄ . "nsub") + (#\⊆ . "sube") + (#\⊇ . "supe") + (#\⊕ . "oplus") + (#\⊗ . "otimes") + (#\⊥ . "perp") + (#\⋅ . "sdot") + (#\⋮ . "vellip") + (#\⌈ . "lceil") + (#\⌉ . "rceil") + (#\⌊ . "lfloor") + (#\⌋ . "rfloor") + (#\〈 . "lang") + (#\〉 . "rang") + (#\◊ . "loz") + (#\♠ . "spades") + (#\♣ . "clubs") + (#\♥ . "hearts") + (#\♦ . "diams")))) + +(define (string->escaped-html s port) + "Write the HTML escaped form of S to PORT." + (define (escape c) + (let ((escaped (hash-ref %escape-chars c))) + (if escaped + (format port "&~a;" escaped) + (display c port)))) + (string-for-each escape s)) + +(define (object->escaped-html obj port) + "Write the HTML escaped form of OBJ to PORT." + (string->escaped-html + (call-with-output-string (cut display obj <>)) + port)) + +(define (attribute-value->html values port) + "Write the HTML escaped form of VALUE to PORT." + (for-each + (lambda (value) + (cond + [(string? value) (string->escaped-html value port)] + [(null? value) *unspecified*] + [else (object->escaped-html value port)])) + values)) + +(define (attribute->html attr values port) + "Write ATTR and VALUES to PORT." + (format port "~a=\"" attr) + (attribute-value->html values port) + (display #\" port)) + +(define (element->html tag attrs body port) + "Write the HTML TAG to PORT, where TAG has the attributes in the +ist ATTRS and the child nodes in BODY." + (format port "<~a" tag) + (for-each (match-lambda + ((attr . values) + (display #\space port) + (attribute->html attr values port))) + attrs) + (if (and (null? body) (void-element? tag)) + (display " />" port) + (begin + (display #\> port) + (for-each (cut sxml->html <> port) body) + (format port "</~a>" tag)))) + +(define (doctype->html doctype port) + (format port "<!DOCTYPE ~a>" doctype)) + +(define (pi->html type body port) + (format port "<?~a ~a?>" type body)) + +(define* (sxml->html tree #:optional (port (current-output-port))) + "Write the serialized HTML form of TREE to PORT." + (match tree + (() *unspecified*) + (('doctype type) + (doctype->html type port)) + ;; Unescaped, raw HTML output + (('raw html-fragments ...) + (for-each (cut display <> port) + html-fragments)) + (('*PI* type body) + (pi->html type body port)) + (('*TOP* nodes ...) + (for-each (cut sxml->html <> port) nodes)) + ((? procedure? proc) ; is whole tree a procedure + (with-output-to-port port proc)) + (((? symbol? tag) ('@ attrs ...) body ...) + (element->html tag attrs body port)) + (((? symbol? tag) body ...) + (element->html tag '() body port)) + ((nodes ...) + (for-each (cut sxml->html <> port) nodes)) + ((? string? text) + (string->escaped-html text port)) + ;; Render arbitrary Scheme objects, too. + (#f *unspecified*) + (obj (object->escaped-html obj port)))) diff --git a/static/components/vevent.ts b/static/components/vevent.ts index b72cda90..2193eabc 100644 --- a/static/components/vevent.ts +++ b/static/components/vevent.ts @@ -15,7 +15,7 @@ abstract class ComponentVEvent extends HTMLElement { constructor(uid?: string) { super(); - this.template = document.getElementById(this.tagName) as HTMLTemplateElement | null + this.template = document.getElementById(this.tagName.toLowerCase()) as HTMLTemplateElement | null let real_uid; diff --git a/static/globals.ts b/static/globals.ts index 2fc12933..ddc9113e 100644 --- a/static/globals.ts +++ b/static/globals.ts @@ -51,7 +51,7 @@ function find_block(uid: uid): ComponentBlock | null { return null; } for (let el of obj.registered) { - if (el.tagName === 'vevent-block') { + if (el.tagName.toLowerCase() === 'vevent-block') { return el as ComponentBlock; } } diff --git a/static/user/user-additions.js b/static/user/user-additions.js index 0de825e8..c0579df5 100644 --- a/static/user/user-additions.js +++ b/static/user/user-additions.js @@ -34,8 +34,10 @@ window.formatters.set('description', (el, d) => { window.salar = new Promise((resolve, reject) => fetch('/static/user/salar.json') - .then(d => d.json()) - .then(d => resolve(d))) + .then(resp => { if (! resp.ok) reject("404"); else resp.json() }) + .then(d => resolve(d)) + .catch(err => reject(err)) +) window.formatters.set('location', async function(el, d) { @@ -46,7 +48,12 @@ window.formatters.set('location', async function(el, d) { return; } - let salar = await window.salar; + try { + let salar = await window.salar; + } catch (e) { + console.warn("Location formatter failed", e); + return; + } let name = m[1] let frag = salar[name]; diff --git a/static/vevent.ts b/static/vevent.ts index 56c9019a..5419eb60 100644 --- a/static/vevent.ts +++ b/static/vevent.ts @@ -298,7 +298,7 @@ function make_vevent_value(value_tag: Element): VEventValue { /* TODO parameters */ return new VEventValue( /* TODO error on invalid type? */ - value_tag.tagName as ical_type, + value_tag.tagName.toLowerCase() as ical_type, make_vevent_value_(value_tag)); } @@ -441,7 +441,7 @@ function xml_to_recurrence_rule(xml: Element): RecurrenceRule { function make_vevent_value_(value_tag: Element): string | boolean | Date | number | RecurrenceRule { /* RFC6321 3.6. */ - switch (value_tag.tagName) { + switch (value_tag.tagName.toLowerCase()) { case 'binary': /* Base64 to binary Seems to handle inline whitespace, which xCal standard reqires @@ -518,10 +518,10 @@ function xml_to_vcal(xml: Element): VEvent { for (var j = 0; j < tag.childElementCount; j++) { let child = tag.childNodes[j]; if (!(child instanceof Element)) continue; - if (child.tagName == 'parameters') { + if (child.tagName.toLowerCase() == 'parameters') { parameters = /* TODO handle parameters */ {}; continue value_loop; - } else switch (tag.tagName) { + } else switch (tag.tagName.toLowerCase()) { /* These can contain multiple value tags, per RFC6321 3.4.1.1. */ case 'categories': @@ -535,7 +535,7 @@ function xml_to_vcal(xml: Element): VEvent { value = make_vevent_value(child); } } - property_map.set(tag.tagName, value); + property_map.set(tag.tagName.toLowerCase(), value); } } diff --git a/tests/test/html/component.scm b/tests/test/html/component.scm index 777068c9..050810be 100644 --- a/tests/test/html/component.scm +++ b/tests/test/html/component.scm @@ -7,23 +7,6 @@ :use-module (calp html components) ) -(test-equal '(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml")) - body)) - (xhtml-doc body)) - -(test-equal '(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml")) - (b "Hello, World!"))) - (xhtml-doc ,'(b "Hello, World!"))) - -(test-equal - '(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (lang sv)) - body)) - (xhtml-doc (@ (lang sv)) body)) - (test-equal '(button (@ (class "btn") (onclick "onclick")) "Body") (btn onclick: "onclick" "Body")) |