diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | module/html/components.scm | 122 | ||||
| -rw-r--r-- | module/output/html-search.scm | 59 | ||||
| -rw-r--r-- | module/output/html.scm | 509 | ||||
| -rw-r--r-- | module/vcomponent/search.scm | 1 |
5 files changed, 366 insertions, 327 deletions
@@ -1,2 +1,2 @@ *.x -html +/html diff --git a/module/html/components.scm b/module/html/components.scm new file mode 100644 index 00000000..77156fc5 --- /dev/null +++ b/module/html/components.scm @@ -0,0 +1,122 @@ +(define-module (html components) + :use-module (util) + :use-module (util exceptions) + :export (xhtml-doc) + ) + +;; Wraps a number of sxml forms into a valid sxhtml-tree. +(define-syntax xhtml-doc + (syntax-rules (@) + ((_ (@ attr ...) body ...) + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") attr ...) + body ...))) + ((_ body ...) + (xhtml-doc (@) body ...)))) + + +;; Add a slider with an associated number input. Keeps the two in check. +;; Uses the js function setVar (which must be provided elsewhere) +;; set the the value of @var{variable}. +(define*-public (slider-input key: variable + (min 0) + (max 10) + (step 1) + (value 1) + (unit "")) + (let ((groupname (symbol->string (gensym "slider")))) + `(div (@ (class "input-group")) + (script + "function " ,groupname "fn (value) {" + "setVar('" ,variable "', value + '" ,unit "');" + "for (let el of document.getElementsByClassName('" ,groupname "')) {" + " el.value = value;" + "}}") + (input (@ (type "range") + (class ,groupname) + (min ,min) + (max ,max) + (step ,step) + (value ,value) + (oninput ,groupname "fn(this.value)") + )) + (input (@ (type "number") + (class ,groupname) + (min ,min) + (max ,max) + (step ,step) + (value ,value) + (oninput ,groupname "fn(this.value)")) + )))) + +;; Generates a button or button-like link. +;; TODO <div/> inside <button/> isn't valid. +(define*-public (btn key: onclick href (class '()) + allow-other-keys: + rest: args) + (when (and onclick href) + (error "Only give one of onclick, href and submit.")) + + (let ((body #f)) + `(,(cond [href 'a] + [else 'button]) + (@ (class ,(string-join (cons "btn" class) " ")) + ,@(cond [onclick `((onclick ,onclick))] + [href `((href ,href))] + [else '()]) + ,@(let loop ((rem args)) + (cond + [(null? rem) '()] + [(memv (car rem) '(onclick: href: class:)) + (loop (cddr rem))] + [(keyword? (car rem)) + (cons* `(,(keyword->symbol (car rem)) + ,(cadr rem)) + (loop (cddr rem)))] + [else + (set! body (car rem)) + (loop (cdr rem))]))) + (div ,body)))) + + +;; Creates a group of tabs from a given specification. The specification +;; @var{elements} should be a list, where each element is a sublist on +;; the form +;; @example +;; ("tab icon" arguments ... tab-body) +;; @end example +;; where arguments are zero or more pairs of keyword arguments. For example: +;; @example +;; ("📅" title: "Översikt" ,(fmt-single-event ev)) +;; @end example +;; Creates a tab with an calendar emoji as icon, "Översikt" is sent as the +;; extra argument #:title, and the body is the return from fmt-single-event. +(define-public (tabset elements) + (define tabgroup (symbol->string (gensym "tabgroup"))) + + `(div (@ (class "tabgroup")) + ,@(for (i (key args ... body)) in (enumerate elements) + (define id (symbol->string (gensym "tab"))) + `(div (@ (class "tab")) + (input (@ (type "radio") (id ,id) (name ,tabgroup) + ,@(when (zero? i) '((checked))))) + (label (@ (for ,id) (style "top: " ,(* 6 i) "ex") + ,(awhen (memv title: args) + `(title ,(cadr it)))) + ,key) + (div (@ (class "content")) ,body))))) + + +(define-public (include-css path . extra-attributes) + `(link (@ (type "text/css") + (rel "stylesheet") + (href ,path) + ,@extra-attributes))) + + +(define-public (include-alt-css path . extra-attributes) + `(link (@ (type "text/css") + (rel "alternate stylesheet") + (href ,path) + ,@extra-attributes))) diff --git a/module/output/html-search.scm b/module/output/html-search.scm index a6a80cd4..f6b74a77 100644 --- a/module/output/html-search.scm +++ b/module/output/html-search.scm @@ -3,36 +3,35 @@ :use-module (util) :use-module (vcomponent) :use-module (vcomponent search) - :use-module (ice-9 format) + :use-module ((ice-9 pretty-print) :select (pretty-print)) + :use-module (html components) ) -(define-public (search-result-page search-term search-result page paginator q=) - `(*TOP* - (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") (lang sv)) - (head (title "Search results") - ;; TODO (@ (output html) include-css) - (link (@ (type "text/css") - (rel "stylesheet") - (href "/static/style.css")))) - (body - (h2 "Search term") - (form - (pre (textarea (@ (name "q") (rows 5) (spellcheck false) - (style "width:100%")) - ,(format #f "~y" search-term))) - (input (@ (type submit)))) - (h2 "Result (page " ,page ")") - (ul - ,@(for event in search-result - `(li (@ (class "event")) - ,(prop event 'SUMMARY)))) - (div (@ (class "paginator")) - ,@(paginator->list - paginator - (lambda (p) (if (= p page) - `(span ,p) - `(a (@ (href "?" ,q= "&p=" ,p)) ,p))) - (lambda (p) `(a (@ (href "?" ,q= "&p=" ,p)) "»")))) - )))) +(define-public (search-result-page + search-term search-result page paginator q=) + (xhtml-doc + (@ (lang sv)) + (head (title "Search results") + ,(include-css "/static/style.css")) + (body + (h2 "Search term") + (form + (pre (textarea (@ (name "q") (rows 5) (spellcheck false) + (style "width:100%")) + ,(with-output-to-string + (lambda () (pretty-print search-term))))) + (input (@ (type submit)))) + (h2 "Result (page " ,page ")") + (ul + ,@(for event in search-result + `(li (@ (class "event")) + ,(prop event 'SUMMARY)))) + (div (@ (class "paginator")) + ,@(paginator->list + paginator + (lambda (p) (if (= p page) + `(span ,p) + `(a (@ (href "?" ,q= "&p=" ,p)) ,p))) + (lambda (p) `(a (@ (href "?" ,q= "&p=" ,p)) "»")))) + ))) diff --git a/module/output/html.scm b/module/output/html.scm index 6e6fcd30..0145a943 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -19,6 +19,8 @@ #:use-module (text util) #:use-module (vcomponent datetime output) + #:use-module (html components) + #:autoload (vcomponent instance) (global-event-object) #:use-module (git) @@ -38,37 +40,7 @@ "Makes the document editable" post: edit-mode) -(define* (slider-input key: variable - (min 0) - (max 10) - (step 1) - (value 1) - (unit "")) - (let ((groupname (symbol->string (gensym "slider")))) - `(div (@ (class "input-group")) - (script - "function " ,groupname "fn (value) {" - "setVar('" ,variable "', value + '" ,unit "');" - "for (let el of document.getElementsByClassName('" ,groupname "')) {" - " el.value = value;" - "}}") - (input (@ (type "range") - (class ,groupname) - (min ,min) - (max ,max) - (step ,step) - (value ,value) - (oninput ,groupname "fn(this.value)") - )) - (input (@ (type "number") - (class ,groupname) - (min ,min) - (max ,max) - (step ,step) - (value ,value) - (oninput ,groupname "fn(this.value)")) - ) - ))) + (define (date-link date) (date->string date "~Y-~m-~d")) @@ -88,47 +60,6 @@ -(define* (btn key: onclick href (class '()) - allow-other-keys: - rest: args) - (when (and onclick href) - (error "Only give one of onclick, href and submit.")) - - (let ((body #f)) - `(,(cond [href 'a] - [else 'button]) - (@ (class ,(string-join (cons "btn" class) " ")) - ,@(cond [onclick `((onclick ,onclick))] - [href `((href ,href))] - [else '()]) - ,@(let loop ((rem args)) - (cond - [(null? rem) '()] - [(memv (car rem) '(onclick: href: class:)) - (loop (cddr rem))] - [(keyword? (car rem)) - (cons* `(,(keyword->symbol (car rem)) - ,(cadr rem)) - (loop (cddr rem)))] - [else - (set! body (car rem)) - (loop (cdr rem))]))) - (div ,body)))) - - -(define (tabset elements) - (define tabgroup (symbol->string (gensym "tabgroup"))) - - `(div (@ (class "tabgroup")) - ,@(for (i (key body)) in (enumerate elements) - (define id (symbol->string (gensym "tab"))) - `(div (@ (class "tab")) - (input (@ (type "radio") (id ,id) (name ,tabgroup) - ,@(when (zero? i) '((checked))))) - ;; TODO title attribute for label - (label (@ (for ,id) (style "top: " ,(* 6 i) "ex")) ,key) - (div (@ (class "content")) ,body))))) - (define (popup ev id) `(div (@ (class "popup-container") (id ,id) (onclick "event.stopPropagation()")) @@ -145,13 +76,15 @@ onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")) ,(tabset - `(("📅" ,(fmt-single-event ev)) - ("⤓" (div (@ (style "font-family:sans")) - (p "Ladda ner") - (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) - "som iCal")) - (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) - "som xCal")))))))))) + `(("📅" title: "Översikt" + ,(fmt-single-event ev)) + ("⤓" title: "Nedladdning" + (div (@ (style "font-family:sans")) + (p "Ladda ner") + (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) + "som iCal")) + (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) + "som xCal")))))))))) @@ -532,20 +465,6 @@ -;;; General HTML help - -(define (include-css path . extra-attributes) - `(link (@ (type "text/css") - (rel "stylesheet") - (href ,path) - ,@extra-attributes))) - -(define (include-alt-css path . extra-attributes) - `(link (@ (type "text/css") - (rel "alternate stylesheet") - (href ,path) - ,@extra-attributes))) - ;; date should be start of month @@ -652,215 +571,213 @@ ;; (display "<!doctype HTML>\n") (;;(@ (ice-9 pretty-print) pretty-print) (@ (sxml simple) sxml->xml) - `(*TOP* - (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") - ;; "<!doctype html>" - (html (@ (xmlns "http://www.w3.org/1999/xhtml") (lang sv)) - (head - (title "Calendar") - (meta (@ (charset "utf-8"))) - ;; (meta (@ (http-equiv "Content-Type") (content "application/xhtml+xml"))) - (meta (@ (name viewport) - (content "width=device-width, initial-scale=0.5"))) - (meta (@ (name description) - (content "Calendar for the dates between " - ,(date->string start-date) " and " - ,(date->string end-date)))) - ;; NOTE this is only for the time actually part of this calendar. - ;; overflowing times from pre-start and post-end is currently ignored here. - (meta (@ (name start-time) - (content ,(date->string start-date "~s")))) - (meta (@ (name end-time) - (content ,(date->string (date+ end-date (date day: 1)) "~s")))) - - (script - "EDIT_MODE=true;") - - (style ,(format #f "html { + (xhtml-doc + (@ (lang sv)) + (head + (title "Calendar") + (meta (@ (charset "utf-8"))) + ;; (meta (@ (http-equiv "Content-Type") (content "application/xhtml+xml"))) + (meta (@ (name viewport) + (content "width=device-width, initial-scale=0.5"))) + (meta (@ (name description) + (content "Calendar for the dates between " + ,(date->string start-date) " and " + ,(date->string end-date)))) + ;; NOTE this is only for the time actually part of this calendar. + ;; overflowing times from pre-start and post-end is currently ignored here. + (meta (@ (name start-time) + (content ,(date->string start-date "~s")))) + (meta (@ (name end-time) + (content ,(date->string (date+ end-date (date day: 1)) "~s")))) + + (script + "EDIT_MODE=true;") + + (style ,(format #f "html { --editmode: 1.0; --event-font-size: 8pt; --gray: #757575; --btn-height: 0.5ex; }")) - ,(include-css "/static/style.css") - ,(include-alt-css "/static/dark.css" '(title "Dark")) - ,(include-alt-css "/static/light.css" '(title "Light")) - - (script (@ (defer) (src "/static/script.js"))) - (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%.CAL_bg_~a { border-color: ~a }~%~}" - (map (lambda (c) - (let* ((name (html-attr (prop c 'NAME))) - (bg-color (prop c 'COLOR)) - (fg-color (and=> (prop c 'COLOR) - calculate-fg-color))) - (list name (or bg-color 'white) (or fg-color 'black) - name (or bg-color 'black)))) - calendars)))) - - (body - (div (@ (class "root")) - (main - ;; Actuall calendar - (@ (style "grid-area: main")) - ,@(render-calendar calendars: calendars - events: events - start-date: start-date - end-date: end-date - pre-start: pre-start - post-end: post-end - next-start: next-start - prev-start: prev-start - ) - - ,@(for event in (stream->list - (events-between pre-start post-end events)) - (popup event (string-append "popup" (html-id event))))) - - ;; Page footer - (footer - (@ (style "grid-area: footer")) - (span "Page generated " ,(date->string (current-date))) - (span (a (@ (href ,(repo-url) "/calparse")) - "Source Code")) - ,(let* ((long-hash short-hash (get-git-version)) - (url (format #f "~a/calparse/commit/?id=~a" - (repo-url) long-hash))) - `(span "Version " (a (@ (href ,url)) ,short-hash)))) - - ;; Small calendar and navigation - (nav (@ (class "calnav") (style "grid-area: nav")) - (div (@ (class "change-view")) - ,(btn href: (date->string - (if (= 1 (day start-date)) - (start-of-week start-date (get-config 'week-start)) - start-date) - "/week/~1.html") - "veckovy") - - ,(btn href: (date->string (set (day start-date) 1) "/month/~1.html") - "månadsvy") - - ,(btn id: "today-button" - href: (string-append - "/today?" (case intervaltype - [(month) "view=month"] - [(week) "view=week"] - [else ""])) - "idag")) - - (div (@ (id "jump-to")) - ;; Firefox's accessability complain about each date - ;; component, meaning that it's broken. This label - ;; is for the whole input, which can be enabled - ;; if wanted. - ;; (label (@ (for "date")) "Hoppa till") - (form (@ (action "/today")) - (input (@ (type hidden) - (name "view") - (value ,(case intervaltype - [(month week) => symbol->string] - [else "month"])))) - (input (@ (type date) - (name "date") - (value ,(date->string start-date "~1")))) - ,(btn "➔")))) - - (details (@ (open) (style "grid-area: cal")) - (summary "Month overview") - (div (@ (class "smallcall-head")) - ,(string-titlecase (date->string start-date "~B ~Y"))) - ;; NOTE it might be a good idea to put the navigation buttons - ;; earlier in the DOM-tree/tag order. At least Vimium's - ;; @key{[[} keybind sometimes finds parts of events instead. - (div (@ (class "smallcal")) - ;; prev button - ,(nav-link "«" (prev-start start-date)) - - ;; calendar table - (div ,(cal-table start-date: start-date end-date: end-date - next-start: next-start - prev-start: prev-start - )) - - ;; next button - ,(nav-link "»" (next-start start-date)))) - - - (div (@ (style "grid-area: details")) - ,(when (or (debug) (edit-mode)) - `(details (@ (class "sliders")) - (summary "Option sliders") - - - ,@(when (edit-mode) - `((label "Event blankspace") - ,(slider-input - variable: "editmode" - min: 0 - max: 1 - step: 0.01 - value: 1))) - - ,@(when (debug) - `((label "Fontsize") - ,(slider-input - unit: "pt" - min: 1 - max: 20 - step: 1 - value: 8 - variable: "event-font-size"))))) - - ;; List of calendars - (details (@ (class "calendarlist")) - (summary "Calendar list") - (ul ,@(map - (lambda (calendar) - `(li (@ (class "CAL_bg_" - ,(html-attr (prop calendar 'NAME)))) - ,(prop calendar 'NAME))) - calendars)))) - - ;; List of events - (div (@ (class "eventlist") - (style "grid-area: events")) - ;; Events which started before our start point, - ;; but "spill" into our time span. - (section (@ (class "text-day")) - (header (h2 "Tidigare")) - ,@(stream->list - (stream-map - fmt-single-event - (stream-take-while - (compose (cut date/-time<? <> start-date) - (extract 'DTSTART)) - (cdr (stream-car evs)))))) - ,@(stream->list (stream-map fmt-day evs)))) - - ;; This would idealy be a <template> element, but there is some - ;; form of special case with those in xhtml, but I can't find - ;; the documentation for it. - ,@(let* ((cal (vcalendar - name: "Generated" - children: (list (vevent - ;; The event template SHOULD lack - ;; a UID, to stop potential problems - ;; with conflicts when multiple it's - ;; cloned mulitple times. - dtstart: (datetime) - dtend: (datetime) - summary: "New Event")))) - (event (car (children cal)))) - `((div (@ (class "template event-container") (id "event-template") - ;; Only needed to create a duration. So actual dates - ;; dosen't matter - (data-start "2020-01-01") - (data-end "2020-01-02")) - ,(caddar ; strip <a> tag - (make-block event `((class " generated "))))) - (div (@ (class "template") (id "popup-template")) - ,(popup event (string-append "popup" (html-id event))))))))))) + ,(include-css "/static/style.css") + ,(include-alt-css "/static/dark.css" '(title "Dark")) + ,(include-alt-css "/static/light.css" '(title "Light")) + + (script (@ (defer) (src "/static/script.js"))) + (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%.CAL_bg_~a { border-color: ~a }~%~}" + (map (lambda (c) + (let* ((name (html-attr (prop c 'NAME))) + (bg-color (prop c 'COLOR)) + (fg-color (and=> (prop c 'COLOR) + calculate-fg-color))) + (list name (or bg-color 'white) (or fg-color 'black) + name (or bg-color 'black)))) + calendars)))) + + (body + (div (@ (class "root")) + (main + ;; Actuall calendar + (@ (style "grid-area: main")) + ,@(render-calendar calendars: calendars + events: events + start-date: start-date + end-date: end-date + pre-start: pre-start + post-end: post-end + next-start: next-start + prev-start: prev-start + ) + + ,@(for event in (stream->list + (events-between pre-start post-end events)) + (popup event (string-append "popup" (html-id event))))) + + ;; Page footer + (footer + (@ (style "grid-area: footer")) + (span "Page generated " ,(date->string (current-date))) + (span (a (@ (href ,(repo-url) "/calparse")) + "Source Code")) + ,(let* ((long-hash short-hash (get-git-version)) + (url (format #f "~a/calparse/commit/?id=~a" + (repo-url) long-hash))) + `(span "Version " (a (@ (href ,url)) ,short-hash)))) + + ;; Small calendar and navigation + (nav (@ (class "calnav") (style "grid-area: nav")) + (div (@ (class "change-view")) + ,(btn href: (date->string + (if (= 1 (day start-date)) + (start-of-week start-date (get-config 'week-start)) + start-date) + "/week/~1.html") + "veckovy") + + ,(btn href: (date->string (set (day start-date) 1) "/month/~1.html") + "månadsvy") + + ,(btn id: "today-button" + href: (string-append + "/today?" (case intervaltype + [(month) "view=month"] + [(week) "view=week"] + [else ""])) + "idag")) + + (div (@ (id "jump-to")) + ;; Firefox's accessability complain about each date + ;; component, meaning that it's broken. This label + ;; is for the whole input, which can be enabled + ;; if wanted. + ;; (label (@ (for "date")) "Hoppa till") + (form (@ (action "/today")) + (input (@ (type hidden) + (name "view") + (value ,(case intervaltype + [(month week) => symbol->string] + [else "month"])))) + (input (@ (type date) + (name "date") + (value ,(date->string start-date "~1")))) + ,(btn "➔")))) + + (details (@ (open) (style "grid-area: cal")) + (summary "Month overview") + (div (@ (class "smallcall-head")) + ,(string-titlecase (date->string start-date "~B ~Y"))) + ;; NOTE it might be a good idea to put the navigation buttons + ;; earlier in the DOM-tree/tag order. At least Vimium's + ;; @key{[[} keybind sometimes finds parts of events instead. + (div (@ (class "smallcal")) + ;; prev button + ,(nav-link "«" (prev-start start-date)) + + ;; calendar table + (div ,(cal-table start-date: start-date end-date: end-date + next-start: next-start + prev-start: prev-start + )) + + ;; next button + ,(nav-link "»" (next-start start-date)))) + + + (div (@ (style "grid-area: details")) + ,(when (or (debug) (edit-mode)) + `(details (@ (class "sliders")) + (summary "Option sliders") + + + ,@(when (edit-mode) + `((label "Event blankspace") + ,(slider-input + variable: "editmode" + min: 0 + max: 1 + step: 0.01 + value: 1))) + + ,@(when (debug) + `((label "Fontsize") + ,(slider-input + unit: "pt" + min: 1 + max: 20 + step: 1 + value: 8 + variable: "event-font-size"))))) + + ;; List of calendars + (details (@ (class "calendarlist")) + (summary "Calendar list") + (ul ,@(map + (lambda (calendar) + `(li (@ (class "CAL_bg_" + ,(html-attr (prop calendar 'NAME)))) + ,(prop calendar 'NAME))) + calendars)))) + + ;; List of events + (div (@ (class "eventlist") + (style "grid-area: events")) + ;; Events which started before our start point, + ;; but "spill" into our time span. + (section (@ (class "text-day")) + (header (h2 "Tidigare")) + ,@(stream->list + (stream-map + fmt-single-event + (stream-take-while + (compose (cut date/-time<? <> start-date) + (extract 'DTSTART)) + (cdr (stream-car evs)))))) + ,@(stream->list (stream-map fmt-day evs)))) + + ;; This would idealy be a <template> element, but there is some + ;; form of special case with those in xhtml, but I can't find + ;; the documentation for it. + ,@(let* ((cal (vcalendar + name: "Generated" + children: (list (vevent + ;; The event template SHOULD lack + ;; a UID, to stop potential problems + ;; with conflicts when multiple it's + ;; cloned mulitple times. + dtstart: (datetime) + dtend: (datetime) + summary: "New Event")))) + (event (car (children cal)))) + `((div (@ (class "template event-container") (id "event-template") + ;; Only needed to create a duration. So actual dates + ;; dosen't matter + (data-start "2020-01-01") + (data-end "2020-01-02")) + ,(caddar ; strip <a> tag + (make-block event `((class " generated "))))) + (div (@ (class "template") (id "popup-template")) + ,(popup event (string-append "popup" (html-id event)))))))))) diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm index 4e604d89..15ff0720 100644 --- a/module/vcomponent/search.scm +++ b/module/vcomponent/search.scm @@ -155,6 +155,7 @@ (set-max-page! paginator (max page (get-max-page paginator))) result)))) (lambda (err proc fmt args data) + ;; TODO ensure the error actually is index out of range. ;; (format (current-error-port) "~?~%" fmt args) (set-max-page! paginator (get-max-page paginator)) (set-true-max-page! paginator) |