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 /module/c | |
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.
Diffstat (limited to '')
-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 |
5 files changed, 44 insertions, 36 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))))) |