diff options
Diffstat (limited to '')
-rw-r--r-- | module/html/util.scm | 31 | ||||
-rw-r--r-- | module/html/vcomponent.scm | 89 | ||||
-rw-r--r-- | module/html/view/calendar.scm | 28 |
3 files changed, 104 insertions, 44 deletions
diff --git a/module/html/util.scm b/module/html/util.scm index 36b1d929..edbcf756 100644 --- a/module/html/util.scm +++ b/module/html/util.scm @@ -1,10 +1,37 @@ (define-module (html util) + :use-module ((util base64) + :select (base64encode base64decode)) :use-module (util)) +;;; @var{html-attr} & @var{html-unattr} used to just strip any +;;; attributes not valid in css. That allowed a human reader to +;;; quickly see what data it was. The downside was that it was one +;;; way. The new base64 based system supports both an encode and a +;;; decode without problem. +;;; +;;; The encoded string substitutes { + => å, / => ä, = => ö } to be +;;; valid CSS selector names. + ;; Retuns an HTML-safe version of @var{str}. (define-public (html-attr str) - (define cs (char-set-adjoin char-set:letter+digit #\- #\_)) - (string-filter (lambda (c) (char-set-contains? cs c)) str)) + (string-map (lambda (c) + (case c + ((#\+) #\å) + ((#\/) #\ä) + ((#\=) #\ö) + (else c))) + (base64encode str))) + +(define-public (html-unattr str) + (base64decode + (string-map (lambda (c) + (case c + ((#\å) #\+) + ((#\ä) #\/) + ((#\ö) #\=) + (else c))) + str))) + (define-public (date-link date) ((@ (datetime) date->string) date "~Y-~m-~d")) diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index 9189b59e..5e7b4ba8 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -44,18 +44,21 @@ ;; TODO better format, add show in calendar button ,(fmt-single-event event))))) -;; For sidebar, just text +;; Format event as text. +;; Used in +;; - sidebar +;; - popup overwiew tab +;; - search result (event details) (define*-public (fmt-single-event ev optional: (attributes '()) key: (fmt-header list)) ;; (format (current-error-port) "fmt-single-event: ~a~%" (prop ev 'X-HNH-FILENAME)) `(article (@ ,@(assq-merge attributes - `((class "eventtext CAL_bg_" - ,(html-attr (or (prop (parent ev) 'NAME) "unknown")) + `((class " eventtext " ,(when (and (prop ev 'PARTSTAT) (eq? 'TENTATIVE (prop ev 'PARTSTAT))) - " tentative"))))) + " tentative "))))) (h3 ,(fmt-header (when (prop ev 'RRULE) `(span (@ (class "repeating")) "↺")) @@ -79,8 +82,9 @@ (div (@ (class "location")) ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) (prop ev 'LOCATION))))) - ,(and=> (prop ev 'DESCRIPTION) - (lambda (str) (format-description ev str))) + ,(awhen (prop ev 'DESCRIPTION) + `(span (@ (class "description")) + ,(format-description ev it))) ,(awhen (prop ev 'RRULE) `(span (@ (class "rrule")) ,@(format-recurrence-rule ev))) @@ -100,13 +104,15 @@ (class "hidelink")) ,s)))) ,@(stream->list (stream-map - (lambda (ev) (fmt-single-event - ev `((id ,(html-id ev))) - fmt-header: - (lambda body - `(a (@ (href "#" ,(date-link (as-date (prop ev 'DTSTART)))) - (class "hidelink")) - ,@body)))) + (lambda (ev) + (fmt-single-event + ev `((id ,(html-id ev)) + (class "CAL_" ,(html-attr (or (prop (parent ev) 'NAME) "unknown")))) + fmt-header: + (lambda body + `(a (@ (href "#" ,(date-link (as-date (prop ev 'DTSTART)))) + (class "hidelink")) + ,@body)))) (stream-filter (lambda (ev) ;; If start was an earlier day @@ -119,16 +125,14 @@ (define-public (calendar-styles calendars) `(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)))) + ,(format #f "~:{.CAL_~a { --color: ~a; --complement: ~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)))) + calendars)))) ;; "Physical" block in calendar view (define*-public (make-block ev optional: (extra-attributes '())) @@ -138,6 +142,7 @@ (div (@ ,@(assq-merge extra-attributes `((id ,(html-id ev)) + (data-calendar ,(html-attr (or (prop (parent ev) 'NAME) "unknown"))) (class "event CAL_" ,(html-attr (or (prop (parent ev) 'NAME) "unknown")) ,(when (and (prop ev 'PARTSTAT) @@ -165,28 +170,34 @@ (define-public (popup ev id) - `(div (@ (class "popup-container") (id ,id) + `(div (@ (id ,id) (class "popup-container CAL_" + ,(html-attr (or (prop (parent ev) 'NAME) + "unknown"))) (onclick "event.stopPropagation()")) + ;; TODO all (?) code uses .popup-container as the popup, while .popup sits and does nothing. + ;; Do something about this? (div (@ (class "popup")) - (nav (@ (class "popup-control CAL_" - ,(html-attr (or (prop (parent ev) 'NAME) - "unknown")))) + (nav (@ (class "popup-control")) ,(btn "×" title: "Stäng" onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))" class: '("close-tooltip")) ,(when (edit-mode) - (btn "🗑" - title: "Ta bort" - onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))"))) + (list + (btn "🖊️" + title: "Redigera" + onclick: "place_in_edit_mode(document.getElementById(this.closest('.popup-container').id.substr(5)))") + (btn "🗑" + title: "Ta bort" + onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")))) ,(tabset - `(("📅" 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")))))))))) + `(("📅" 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")))))))))) diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index a15b5c1d..a0de3551 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -16,10 +16,14 @@ )) :use-module (html config) :use-module (html util) + + :use-module (util config) + :use-module (srfi srfi-1) :use-module (srfi srfi-26) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) + :use-module ((vcomponent group) :select (group-stream get-groups-between)) :use-module ((git) @@ -292,10 +296,22 @@ (summary "Calendar list") (ul ,@(map (lambda (calendar) - `(li (@ (class "CAL_bg_" + `(li (@ (class "CAL_" ,(html-attr (prop calendar 'NAME)))) ,(prop calendar 'NAME))) - calendars)))) + calendars)) + (div (@ (id "calendar-dropdown-template") (class "template")) + (select + (option "- Choose a Calendar -") + ,@(let ((dflt (get-config 'default-calendar))) + (map (lambda (calendar) + (define name (prop calendar 'NAME)) + `(option (@ (value ,(html-attr name)) + ,@(when (string=? name dflt) + '((selected)))) + ,name)) + calendars))) + ))) ;; List of events (div (@ (class "eventlist") @@ -304,6 +320,8 @@ ;; but "spill" into our time span. (section (@ (class "text-day")) (header (h2 "Tidigare")) + ;; TODO this group gets styles applied incorrectly. + ;; Figure out way to merge it with the below call. ,@(stream->list (stream-map fmt-single-event @@ -325,7 +343,11 @@ ;; cloned mulitple times. dtstart: (datetime) dtend: (datetime) - summary: "New Event")))) + summary: "" + ;; force a description field, + ;; but don't put anything in + ;; it. + description: "")))) (event (car (children cal)))) `((div (@ (class "template event-container") (id "event-template") ;; Only needed to create a duration. So actual dates |