aboutsummaryrefslogtreecommitdiff
path: root/module/calp
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@lysator.liu.se>2022-06-12 00:13:02 +0200
committerHugo Hörnquist <hugo@lysator.liu.se>2022-06-12 00:13:02 +0200
commitda8d1467dff8b27af7a3ae649d92ead5cbf704d8 (patch)
treecd4231abb8ec24d79dd3a4a8b5e563ee2bb82219 /module/calp
parentAdd number of TODO's. (diff)
parentHandle error for user-additions salar. (diff)
downloadcalp-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 'module/calp')
-rw-r--r--module/calp/html/components.scm1
-rw-r--r--module/calp/html/view/calendar.scm7
-rw-r--r--module/calp/html/view/calendar/month.scm2
-rw-r--r--module/calp/html/view/calendar/week.scm2
-rw-r--r--module/calp/server/routes.scm68
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)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-16 12:14:55 +0200