From acd9214946d54f769d2d7c916e53bed29c3ea036 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 11 Jun 2022 19:27:59 +0200 Subject: Re-add (sxml html). See future commits for rationale. This reverts commit 54fc8cf92e9212cc88c824f7b49549160d860657. --- module/sxml/html.scm | 377 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 377 insertions(+) create mode 100644 module/sxml/html.scm diff --git a/module/sxml/html.scm b/module/sxml/html.scm new file mode 100644 index 00000000..94015460 --- /dev/null +++ b/module/sxml/html.scm @@ -0,0 +1,377 @@ +;; Copyright © 2015 David Thompson +;; +;; 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 +;; . + +;; 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 "" tag)))) + +(define (doctype->html doctype port) + (format port "" doctype)) + +(define (pi->html type body port) + (format port "" 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)) + (((? 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)))) -- cgit v1.2.3 From 1bbefbe6ef5b18c7b6f72d7fb9abd759c3fbca3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 11 Jun 2022 20:29:37 +0200 Subject: Extend sxml->html to copy procedures output verbatim. sxml->xml already allows arbitrary strings to be included through procedures current output port. This adds the same feature to sxml->html for feature parity. --- module/sxml/html.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/module/sxml/html.scm b/module/sxml/html.scm index 94015460..473cfd9e 100644 --- a/module/sxml/html.scm +++ b/module/sxml/html.scm @@ -364,6 +364,8 @@ ist ATTRS and the child nodes in 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 ...) -- cgit v1.2.3 From 709c6f68da124d9fd916aa02f4bd95ca2c197db6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 11 Jun 2022 23:08:41 +0200 Subject: Add to xhtml-doc macro. The doctype declaration is "required" when outputing regular HTML, and fine when output XHTML. Also remove the tests of xhtml-doc, since they basically just copied the deffinition (and stoped working since a procedure can't easily be tested for equality). --- module/calp/html/components.scm | 1 + tests/test/html/component.scm | 22 ---------------------- 2 files changed, 1 insertion(+), 22 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 "~%~%")) (html (@ (xmlns "http://www.w3.org/1999/xhtml") attr ...) body ...))) ((_ body ...) diff --git a/tests/test/html/component.scm b/tests/test/html/component.scm index 97581c50..050810be 100644 --- a/tests/test/html/component.scm +++ b/tests/test/html/component.scm @@ -7,28 +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)) - - -;; TODO Slider not tested, due to depending on gensyms, and really needing -;; integration testing to be worth anything. - - (test-equal '(button (@ (class "btn") (onclick "onclick")) "Body") (btn onclick: "onclick" "Body")) -- cgit v1.2.3 From fb38f4ba7b1711d436c303f9de34c8c34f29168c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 11 Jun 2022 23:17:14 +0200 Subject: Embedd fragile strings in sxml in procedures. Since procedures allow direct controll of the output. Everything worked fine for XML output, but HTML encodes apostrophes as ', which works really bad in script tags. --- module/calp/html/view/calendar.scm | 7 +++---- module/calp/html/view/calendar/month.scm | 2 +- module/calp/html/view/calendar/week.scm | 2 +- 3 files changed, 5 insertions(+), 6 deletions(-) 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 -- cgit v1.2.3 From 8da01b382ce43802ef164b86cc7e8c714d85a0f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 11 Jun 2022 23:18:11 +0200 Subject: Follow all instances of tagName with toLowerCase. A HTML document returns tag names as upper case, while xml documents return them as lower case (or possibly their original case). --- static/components/vevent.ts | 2 +- static/globals.ts | 2 +- static/vevent.ts | 10 +++++----- 3 files changed, 7 insertions(+), 7 deletions(-) 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/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); } } -- cgit v1.2.3 From d03d248b4e3ee2fc868508dcf0cb673ce51ef66c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 11 Jun 2022 23:43:19 +0200 Subject: Add html parameter to routes. Finally making the few previous commits worth something. --- module/calp/server/routes.scm | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 0876aed4..dfe0c238 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) @@ -45,6 +46,12 @@ (with-output-to-string (lambda () (display "\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)) + ;; @var{prefix} directory tree which should be exported @@ -141,14 +148,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 +164,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 +359,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 +401,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?)) -- cgit v1.2.3 From fc7b6df70ed416236ddd1dd1f3945050caeff250 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 12 Jun 2022 00:05:40 +0200 Subject: Update remaining routse to new xml or html system. The old sxml->html-string was always wrong, since smxl->xml doesn't (necessarily) produce valid HTML. Now we get proper HTML or XHTML, depending on the `html' parameter. --- module/calp/server/routes.scm | 38 +++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index dfe0c238..2e8f1131 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -38,14 +38,12 @@ :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 "\n") (sxml->xml sxml)))) - (define (content-type html?) (if html? 'text/html 'application/xhtml+xml)) @@ -125,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 @@ -134,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 @@ -437,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))))) -- cgit v1.2.3 From b788aa05b12642ebacef394238a54d11c3d64e09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 11 Jun 2022 23:44:53 +0200 Subject: Handle error for user-additions salar. The script crashes just as before, but now we get slightly better error messages. --- static/user/user-additions.js | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) 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]; -- cgit v1.2.3