diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2021-12-20 22:09:57 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2021-12-20 22:09:57 +0100 |
commit | d75ebbab2a414fe1a9a09d703a3bc7be782f1f1e (patch) | |
tree | 0de4f1c17afd6fbefbafc3a0a8a91bc85cb30355 /module/c | |
parent | Document testrunner syntax. (diff) | |
parent | Documentation updates for util. (diff) | |
download | calp-d75ebbab2a414fe1a9a09d703a3bc7be782f1f1e.tar.gz calp-d75ebbab2a414fe1a9a09d703a3bc7be782f1f1e.tar.xz |
Merge Javascript rewrite.
Diffstat (limited to '')
-rw-r--r-- | module/calp/html/components.scm | 2 | ||||
-rw-r--r-- | module/calp/html/util.scm | 31 | ||||
-rw-r--r-- | module/calp/html/vcomponent.scm | 974 | ||||
-rw-r--r-- | module/calp/html/view/calendar.scm | 214 | ||||
-rw-r--r-- | module/calp/html/view/calendar/month.scm | 27 | ||||
-rw-r--r-- | module/calp/html/view/calendar/week.scm | 61 | ||||
-rw-r--r-- | module/calp/server/routes.scm | 14 | ||||
-rw-r--r-- | module/calp/util.scm | 40 |
8 files changed, 716 insertions, 647 deletions
diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index 816975e7..1d677c0d 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -79,7 +79,7 @@ [else (set! body (car rem)) (loop (cdr rem))]))) - (div ,body)))) + ,body))) ;; Creates a group of tabs from a given specification. The specification diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm index cd5aaeab..40852279 100644 --- a/module/calp/html/util.scm +++ b/module/calp/html/util.scm @@ -1,42 +1,11 @@ (define-module (calp html util) - :use-module ((base64) :select (base64encode base64decode)) :use-module (calp 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) - (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")) - ;; Generate an html id for an event. ;; TODO? same event placed multiple times, when spanning multiple cells (define-public html-id diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 105c6cc5..3e7cc4dc 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -1,5 +1,6 @@ (define-module (calp html vcomponent) :use-module (calp util) + :use-module ((calp util exceptions) :select (warning)) :use-module (vcomponent) :use-module (srfi srfi-1) :use-module (srfi srfi-26) @@ -14,6 +15,7 @@ :use-module ((calp util color) :select (calculate-fg-color)) :use-module ((crypto) :select (sha256 checksum->string)) :use-module ((xdg basedir) :prefix xdg-) + :use-module ((vcomponent recurrence) :select (repeating?)) :use-module ((vcomponent recurrence internal) :prefix #{rrule:}#) :use-module ((vcomponent datetime output) :select (fmt-time-span @@ -21,8 +23,11 @@ format-summary format-recurrence-rule )) + :use-module ((calp util config) :select (get-config)) + :use-module ((base64) :select (base64encode)) ) +;; used by search view (define-public (compact-event-list list) (define calendars @@ -33,11 +38,12 @@ (define (summary event) `(summary (div (@ (class "summary-line ")) - (span (@ (class "square CAL_" - ,(html-attr - (or (prop (parent event) - 'NAME) - "unknown"))))) + (span (@ (class "square") + (data-calendar + ,(base64encode + (or (prop (parent event) + 'NAME) + "unknown"))))) (time ,(let ((dt (prop event 'DTSTART))) (if (datetime? dt) (datetime->string dt "~Y-~m-~d ~H:~M") @@ -58,259 +64,144 @@ ;; - sidebar ;; - popup overwiew tab ;; - search result (event details) +;; Note that the <vevent-description/> tag is bound as a JS custem element, which +;; will re-render all this, through description-template. This also means that +;; the procedures output is intended to be static, and to NOT be changed by JavaScript. (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)) - `(div (@ ,@(assq-merge - attributes - `((data-bindby "bind_view") - (class " eventtext summary-tab " - ,(when (and (prop ev 'PARTSTAT) - (eq? 'TENTATIVE (prop ev 'PARTSTAT))) - " tentative "))))) - (h3 ,(fmt-header - (when (prop ev 'RRULE) - `(span (@ (class "repeating")) "↺")) - `(span (@ (class "bind summary") - (data-property "summary")) - ,(prop ev 'SUMMARY)))) - (div - ,(call-with-values (lambda () (fmt-time-span ev)) - (case-lambda [(start) - `(div (time (@ (class "bind dtstart") - (data-property "dtstart") - (data-fmt ,(string-append "~L" start)) - (datetime ,(datetime->string - (as-datetime (prop ev 'DTSTART)) - "~1T~3"))) - ,(datetime->string - (as-datetime (prop ev 'DTSTART)) - start)))] - [(start end) - `(div (time (@ (class "bind dtstart") - (data-property "dtstart") - (data-fmt ,(string-append "~L" start)) - (datetime ,(datetime->string - (as-datetime (prop ev 'DTSTART)) - "~1T~3"))) - ,(datetime->string (as-datetime (prop ev 'DTSTART)) - start)) - " — " - (time (@ (class "bind dtend") - (data-property "dtend") - (data-fmt ,(string-append "~L" end)) - (datetime ,(datetime->string - (as-datetime (prop ev 'DTSTART)) - "~1T~3"))) - ,(datetime->string (as-datetime (prop ev 'DTEND)) - end)))])) - - ;; TODO add optional fields when added in frontend - ;; Possibly by always having them here, just hidden. - - (div (@ (class "fields")) - ,(when (and=> (prop ev 'LOCATION) (negate string-null?)) - `(div (b "Plats: ") - (div (@ (class "bind location") (data-property "location")) - ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) - (prop ev 'LOCATION))))) - ,(awhen (prop ev 'DESCRIPTION) - `(div (@ (class "bind description") - (data-property "description")) - ,(format-description ev it))) - - ,@(awhen (prop* ev 'ATTACH) - ;; attach satisfies @code{vline?} - (for attach in it - (if (and=> (param attach 'VALUE) - (lambda (p) (string=? "BINARY" (car p)))) - ;; Binary data - ;; TODO guess datatype if FMTTYPE is missing - (awhen (and=> (param attach 'FMTTYPE) - (lambda (it) (string-split - (car it) #\/))) - ;; TODO other file formats - (when (string=? "image" (car it)) - (let* ((chk (-> (value attach) - sha256 - checksum->string)) - (dname - (path-append (xdg-runtime-dir) - "calp-data" "images")) - (filename (-> dname - (path-append chk) - ;; TODO second part of mimetypes - ;; doesn't always result in a valid - ;; file extension. - ;; Take a look in mime.types. - (string-append "." (cadr it))))) - (unless (file-exists? filename) - ;; TODO handle tmp directory globaly - (mkdir (dirname dname)) - (mkdir dname) - (call-with-output-file filename - (lambda (port) - (put-bytevector port (value attach))))) - (let ((link (path-append - "/tmpfiles" - ;; TODO better mimetype to extension - (string-append chk "." (cadr it))))) - `(a (@ (href ,link)) - (img (@ (class "attach") - (src ,link)))))))) - ;; URI - (cond ((and=> (param attach 'FMTTYPE) - (compose (cut string= <> "image" 0 5) car)) - `(img (@ (class "attach") - (src ,(value attach))))) - (else `(a (@ (class "attach") - (href ,(value attach))) - ,(value attach))))))) - - ;; TODO add bind once I figure out how to bind lists - ,(awhen (prop ev 'CATEGORIES) - `(div (@ (class "categories")) - ,@(map (lambda (c) - `(a (@ (class "category") - ;; TODO centralize search terms - (href - "/search/?" - ,(encode-query-parameters - `((q . (member - ,(->string c) - (or (prop event 'CATEGORIES) - '()))))))) - ,c)) - it))) - - ;; TODO bind - ,(awhen (prop ev 'RRULE) - `(div (@ (class "rrule")) - ,@(format-recurrence-rule ev))) - - ,(when (prop ev 'LAST-MODIFIED) - `(div (@ (class "last-modified")) "Senast ändrad " - ,(datetime->string (prop ev 'LAST-MODIFIED) "~1 ~H:~M")))) - - ))) - -(define*-public (fmt-for-edit ev - optional: (attributes '()) - key: (fmt-header list)) - `(div (@ (class " eventtext edit-tab ") - (data-bindby "bind_edit")) - (form (@ (class "edit-form")) - (div (@ (class "dropdown-goes-here"))) - (h3 (input (@ (type "text") - (placeholder "Sammanfattning") - (name "summary") (required) - (class "bind") (data-property "summary") - (value ,(prop ev 'SUMMARY))))) - - ,(let ((start (prop ev 'DTSTART)) - (end (prop ev 'DTEND))) - `(div (@ (class "timeinput")) - - ,@(with-label - "Starttid" - `(div (@ (class "date-time bind") - (data-bindby "bind_date_time") - (name "dtstart")) - (input (@ (type "date") - (value ,(date->string (as-date start))))) - (input (@ (type "time") - (value ,(time->string (as-time start) "~H:~M")) - ,@(when (date? start) '((disabled))) - )))) - - ;; TODO some way to add an endtime if missing beforehand - ;; TODO, actually proper support for event without end times - ,@(when end - (with-label - "Sluttid" - `(div (@ (class "date-time bind") - (data-bindby "bind_date_time") - (name "dtend")) - (input (@ (type "date") - (value ,(date->string (as-date end))))) - (input (@ (type "time") - (value ,(time->string (as-time end) "~H:~M")) - ,@(when (date? end) '((disabled)))))))) - - (div - ,@(with-label - "Heldag?" - `(input (@ (type "checkbox") - (class "bind") - (data-bindby "bind_wholeday") - (name "wholeday") - ,@(when (date? start) '((checked))))))) - - )) - - ,@(with-label - "Plats" - `(input (@ (placeholder "Plats") - (name "location") - (type "text") - (class "bind") (data-property "location") - (value ,(or (prop ev 'LOCATION) ""))))) - - ,@(with-label - "Beskrivning" - `(textarea (@ (placeholder "Beskrivning") - (class "bind") (data-property "description") - (name "description")) - ,(prop ev 'DESCRIPTION))) - - ,@(with-label - "Kategorier" - ;; It would be better if these input-list's worked on the same - ;; class=bind system as the fields above. The problem with that - ;; is however that each input-list requires different search - ;; and join procedures. Currently this is bound in the JS, see - ;; [CATEGORIES_BIND]. - ;; It matches on ".input-list[data-property='categories']". - `(div (@ (class "input-list") - (data-property "categories")) - ,@(awhen (prop ev 'CATEGORIES) - (map (lambda (c) - `(input (@ (size 2) - (class "unit") - (value ,c)))) - it)) - - (input (@ (class "unit final") - (size 2) - (type "text") - )))) - - (hr) - - ;; For custom user fields - ;; TODO these are currently not bound to anything, so entering data - ;; here does nothing. Bigest hurdle to overcome is supporting arbitrary - ;; fields which will come and go in the JavaScript. - ;; TODO also, all (most? maybe not LAST-MODIFIED) remaining properties - ;; should be exposed here. - (div (@ (class "input-list")) - (div (@ (class "unit final newfield")) - (input (@ (type "text") - (list "known-fields") - (placeholder "Nytt fält"))) - (select (@ (name "TYPE")) - (option (@ (value "TEXT")) "Text")) - (span - (input (@ (type "text") - (placeholder "Värde")))))) - - (hr) + `(vevent-description + (@ ,@(assq-merge + attributes + `( + (class ,(when (and (prop ev 'PARTSTAT) + (eq? 'TENTATIVE (prop ev 'PARTSTAT))) + " tentative ")) + (data-uid ,(output-uid ev))))) + (div (@ (class "vevent eventtext summary-tab")) + (h3 ,(fmt-header + (when (prop ev 'RRULE) + `(span (@ (class "repeating")) "↺")) + `(span (@ (class "summary") + (data-property "summary")) + ,(prop ev 'SUMMARY)))) + (div + ,(call-with-values (lambda () (fmt-time-span ev)) + (case-lambda [(start) + `(div (time (@ (class "dtstart") + (data-property "dtstart") + (data-fmt ,(string-append "~L" start)) + (datetime ,(datetime->string + (as-datetime (prop ev 'DTSTART)) + "~1T~3"))) + ,(datetime->string + (as-datetime (prop ev 'DTSTART)) + start)))] + [(start end) + `(div (time (@ (class "dtstart") + (data-property "dtstart") + (data-fmt ,(string-append "~L" start)) + (datetime ,(datetime->string + (as-datetime (prop ev 'DTSTART)) + "~1T~3"))) + ,(datetime->string (as-datetime (prop ev 'DTSTART)) + start)) + " — " + (time (@ (class "dtend") + (data-property "dtend") + (data-fmt ,(string-append "~L" end)) + (datetime ,(datetime->string + (as-datetime (prop ev 'DTSTART)) + "~1T~3"))) + ,(datetime->string (as-datetime (prop ev 'DTEND)) + end)))])) + + (div (@ (class "fields")) + ,(when (and=> (prop ev 'LOCATION) (negate string-null?)) + `(div (b "Plats: ") + (div (@ (class "location") (data-property "location")) + ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) + (prop ev 'LOCATION))))) + ,(awhen (prop ev 'DESCRIPTION) + `(div (@ (class "description") + (data-property "description")) + ,(format-description ev it))) + + ,@(awhen (prop* ev 'ATTACH) + ;; attach satisfies @code{vline?} + (for attach in it + (if (and=> (param attach 'VALUE) + (lambda (p) (string=? "BINARY" (car p)))) + ;; Binary data + ;; TODO guess datatype if FMTTYPE is missing + (awhen (and=> (param attach 'FMTTYPE) + (lambda (it) (string-split + (car it) #\/))) + ;; TODO other file formats + (when (string=? "image" (car it)) + (let* ((chk (-> (value attach) + sha256 + checksum->string)) + (dname + (path-append (xdg-runtime-dir) + "calp-data" "images")) + (filename (-> dname + (path-append chk) + ;; TODO second part of mimetypes + ;; doesn't always result in a valid + ;; file extension. + ;; Take a look in mime.types. + (string-append "." (cadr it))))) + (unless (file-exists? filename) + ;; TODO handle tmp directory globaly + (mkdir (dirname dname)) + (mkdir dname) + (call-with-output-file filename + (lambda (port) + (put-bytevector port (value attach))))) + (let ((link (path-append + "/tmpfiles" + ;; TODO better mimetype to extension + (string-append chk "." (cadr it))))) + `(a (@ (href ,link)) + (img (@ (class "attach") + (src ,link)))))))) + ;; URI + (cond ((and=> (param attach 'FMTTYPE) + (compose (cut string= <> "image" 0 5) car)) + `(img (@ (class "attach") + (src ,(value attach))))) + (else `(a (@ (class "attach") + (href ,(value attach))) + ,(value attach))))))) + + ,(awhen (prop ev 'CATEGORIES) + `(div (@ (class "categories")) + ,@(map (lambda (c) + `(a (@ (class "category") + ;; TODO centralize search terms + (href + "/search/?" + ,(encode-query-parameters + `((q . (member + ,(->string c) + (or (prop event 'CATEGORIES) + '()))))))) + ,c)) + it))) + + ,(awhen (prop ev 'RRULE) + `(div (@ (class "rrule")) + ,@(format-recurrence-rule ev))) + + ,(when (prop ev 'LAST-MODIFIED) + `(div (@ (class "last-modified")) "Senast ändrad " + ,(datetime->string (prop ev 'LAST-MODIFIED) "~1 ~H:~M")))) + + )))) - (input (@ (type "submit"))) - ))) - ;; Single event in side bar (text objects) (define-public (fmt-day day) @@ -324,7 +215,7 @@ (lambda (ev) (fmt-single-event ev `((id ,(html-id ev)) - (class "CAL_" ,(html-attr (or (prop (parent ev) 'NAME) "unknown")))) + (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) "unknown")))) fmt-header: (lambda body `(a (@ (href "#" ,(html-id ev) #; (date-link (as-date (prop ev 'DTSTART))) @@ -341,60 +232,61 @@ events)))))) +;; Specific styles for each calendar. +;; TODO only emit the CSS here, requiring the caller to handle the context, +;; since that would allow us to use this in other contexts. (define-public (calendar-styles calendars) `(style - ,(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)))) + ,(lambda () (format #t "~:{ [data-calendar=\"~a\"] { --color: ~a; --complement: ~a }~%~}" + (map (lambda (c) + (let* ((name (base64encode (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 '())) + ;; surrounding <a /> element which allows something to happen when an element + ;; is clicked with JS turned off. Our JS disables this, and handles clicks itself. `((a (@ (href "#" ,(html-id ev)) (class "hidelink")) - (div (@ ,@(assq-merge - extra-attributes - `((id ,(html-id ev)) - (data-calendar ,(html-attr (or (prop (parent ev) 'NAME) "unknown"))) - ;; (data-bindon "bind_view") - (class "event CAL_" ,(html-attr (or (prop (parent ev) 'NAME) - "unknown")) - ,(when (and (prop ev 'PARTSTAT) - (eq? 'TENTATIVE (prop ev 'PARTSTAT))) - " tentative") - ,(when (and (prop ev 'TRANSP) - (eq? 'TRANSPARENT (prop ev 'TRANSP))) - " transparent") - ) - (onclick "toggle_popup('popup' + this.id)") - ))) - ;; Inner div to prevent overflow. Previously "overflow: none" - ;; was set on the surounding div, but the popup /needs/ to - ;; overflow (for the tabs?). - (div (@ (class "event-body")) - ,(when (prop ev 'RRULE) - `(span (@ (class "repeating")) "↺")) - (span (@ (class "bind summary") - (data-property "summary")) - ,(format-summary ev (prop ev 'SUMMARY))) - ,(when (prop ev 'LOCATION) - `(span (@ (class "bind location") - (data-property "location")) - ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) - (prop ev 'LOCATION)))) - ;; Document symbol when we have text - ,(when (and=> (prop ev 'DESCRIPTION) (negate string-null?)) - `(span (@ (class "description")) - "🗎"))) - (div (@ (style "display:none !important;")) - ,((@ (vcomponent xcal output) ns-wrap) - ((@ (vcomponent xcal output) vcomponent->sxcal) - ev))))))) + (vevent-block (@ ,@(assq-merge + extra-attributes + `((id ,(html-id ev)) + (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) "unknown"))) + (data-uid ,(output-uid ev)) + + (class "vevent event" + ,(when (and (prop ev 'PARTSTAT) + (eq? 'TENTATIVE (prop ev 'PARTSTAT))) + " tentative") + ,(when (and (prop ev 'TRANSP) + (eq? 'TRANSPARENT (prop ev 'TRANSP))) + " transparent") + )))) + ;; Inner div to prevent overflow. Previously "overflow: none" + ;; was set on the surounding div, but the popup /needs/ to + ;; overflow (for the tabs?). + ;; TODO the above comment is no longer valid. Popups are now stored + ;; separately from the block. + (div (@ (class "event-body")) + ,(when (prop ev 'RRULE) + `(span (@ (class "repeating")) "↺")) + (span (@ (class "summary") + (data-property "summary")) + ,(format-summary ev (prop ev 'SUMMARY))) + ,(when (prop ev 'LOCATION) + `(span (@ (class "location") + (data-property "location")) + ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) + (prop ev 'LOCATION)))) + ;; Document symbol when we have text + ,(when (and=> (prop ev 'DESCRIPTION) (negate string-null?)) + `(span (@ (class "description")) + "🗎"))))))) (define (repeat-info event) @@ -421,208 +313,284 @@ (else (->string value)))))) (prop event 'RRULE))))) -;; TODO bind this into the xcal -(define (editable-repeat-info event) - `(div (@ (class "eventtext")) - (h2 "Upprepningar") - ,@(when (debug) - '((button (@ (style "position:absolute;right:1ex;top:1ex") - (onclick "console.log(event_from_popup(this.closest('.popup-container')).properties.rrule.asJcal());")) - "js"))) - (table (@ (class "recur-components bind") - (name "rrule") - (data-bindby "bind_recur")) - ,@(map ; (@@ (vcomponent recurrence internal) map-fields) - (lambda (key ) - `(tr (@ (class ,key)) (th ,key) - (td - ,(case key - ((freq) - `(select (@ (class "bind-rr") (name "freq")) - (option "-") - ,@(map (lambda (x) `(option (@ (value ,x) - ,@(awhen (prop event 'RRULE) - (awhen (rrule:freq it) - (awhen (eq? it x) - '((selected)))))) - ,(string-titlecase - (symbol->string x)))) - '(SECONDLY MINUTELY HOURLY - DAILY WEEKLY - MONTHLY YEARLY)))) - ((until) - (if (date? (prop event 'DTSTART)) - `(input (@ (type "date") - (name "until") - (class "bind-rr") - (value ,(awhen (prop event 'RRULE) - (awhen (rrule:until it) - (date->string it)))))) - `(span (@ (class "bind-rr date-time") - (name "until")) - (input (@ (type "date") - (value ,(awhen (prop event 'RRULE) - (awhen (rrule:until it) - (date->string - (as-date it))))))) - (input (@ (type "time") - (value ,(awhen (prop event 'RRULE) - (awhen (rrule:until it) - (time->string - (as-time it)))))))))) - ((count) - `(input (@ (type number) (min 0) (size 4) - (value ,(awhen (prop event 'RRULE) - (or (rrule:count it) ""))) - (name "count") - (class "bind-rr") - ))) - ((interval) - `(input (@ (type number) (min 0) (size 4) - (value ,(awhen (prop event 'RRULE) - (or (rrule:interval it) ""))) - (name "interval") - (class "bind-rr")))) - ((wkst) - `(select (@ (name "wkst") (class "bind-rr")) - (option "-") - ,@(map (lambda (i) - `(option (@ (value ,i) - ,@(awhen (prop event 'RRULE) - (awhen (rrule:wkst it) - (awhen (eqv? it i) - '((selected)))))) - ,(week-day-name i))) - (iota 7)))) - - ((byday) - (let ((input (lambda* (optional: (byday '(#f . #f)) key: final?) - `(div (@ (class "unit" ,(if final? " final" ""))) - ;; TODO make this thiner, and clearer that - ;; it belongs to the following dropdown - (input (@ (type number) - (value ,(awhen (car byday) it)))) - (select (option "-") - ,@(map (lambda (i) - `(option (@ (value ,i) - ,@(if (eqv? i (cdr byday)) - '((selected)) '())) - ,(week-day-name i))) - (iota 7))))))) - ;; TODO how does this bind? - `(div (@ (class "bind-rr input-list")) - ,@(cond ((and=> (prop event 'RRULE) - rrule:byday) - => (lambda (it) (map input it))) - (else '())) - - ,(input final?: #t)))) - - ((bysecond byminute byhour - bymonthday byyearday - byweekno bymonth bysetpos) - (let ((input - (lambda* (value optional: (final "")) - `(input (@ (class "unit " ,final) - (type "number") - (size 2) - (value ,value) - (min ,(case key - ((bysecond byminute byhour) 0) - ((bymonthday) -31) - ((byyearday) -366) - ((byweekno) -53) - ((bymonth) -12) - ((bysetpos) -366) - )) - (max ,(case key - ((bysecond) 60) - ((byminute) 59) - ((byhour) 23) - ((bymonthday) 31) - ((byyearday) 366) - ((byweekno) 53) - ((bymonth) 12) - ((bysetpos) 366)))))))) - `(div (@ (name ,key) - (class "bind-rr input-list")) - ,@(map input - (awhen (prop event 'RRULE) - (or ((case key - ((bysecond) rrule:bysecond) - ((byminute) rrule:byminute) - ((byhour) rrule:byhour) - ((bymonthday) rrule:bymonthday) - ((byyearday) rrule:byyearday) - ((byweekno) rrule:byweekno) - ((bymonth) rrule:bymonth) - ((bysetpos) rrule:bysetpos)) - it) - '()))) - ,(input '() "final")))) - (else (error "Unknown field, " key)))) - - ;; TODO enable this button - (td (button (@ (class "clear-input") (title "Rensa input")) "🗙")) + +;; Return a unique identifier for a specific instance of an event. +;; Allows us to reference each instance of a repeating event separately +;; from any other +(define-public (output-uid event) + (string-concatenate + (cons + (prop event 'UID) + (when (repeating? event) + ;; TODO this will break if a UID already looks like this... + ;; Just using a pre-generated unique string would solve it, + ;; until someone wants to break us. Therefore, we just give + ;; up for now, until a proper solution can be devised. + (list "---" + ;; TODO Will this give us a unique identifier? + ;; Or can two events share UID along with start time + (datetime->string + (as-datetime (or + ;; TODO What happens if the parameter RANGE=THISANDFUTURE is set? + (prop event 'RECURRENCE-ID) + (prop event 'DTSTART))) + "~Y-~m-~dT~H:~M:~S")))))) + + +(define (week-day-select args) + `(select (@ ,@args) + (option "-") + ,@(map (lambda (x) `(option (@ (value ,(car x))) ,(cadr x))) + '((MO "Monday") + (TU "Tuesday") + (WE "Wednesday") + (TH "Thursday") + (FR "Friday") + (SA "Saturday") + (SU "Sunday"))))) + + +;;; Templates + + +;; edit tab of popup +(define-public (edit-template calendars) + `(template + (@ (id "vevent-edit")) + (div (@ (class " eventtext edit-tab ")) + (form (@ (class "edit-form")) + (select (@ (class "calendar-selection")) + (option "- Choose a Calendar -") + ,@(let ((dflt (get-config 'default-calendar))) + (map (lambda (calendar) + (define name (prop calendar 'NAME)) + `(option (@ (value ,(base64encode name)) + ,@(when (string=? name dflt) + '((selected)))) + ,name)) + calendars))) + (h3 (input (@ (type "text") + (placeholder "Sammanfattning") + (name "summary") (required) + (data-property "summary") + ; (value ,(prop ev 'SUMMARY)) + ))) + + (div (@ (class "timeinput")) + + ,@(with-label + "Starttid" + '(date-time-input (@ (name "dtstart") + (data-property "dtstart") + ))) + + ,@(with-label + "Sluttid" + '(date-time-input (@ (name "dtend") + (data-property "dtend")))) + + (div (@ (class "checkboxes")) + ,@(with-label + "Heldag?" + `(input (@ (type "checkbox") + (name "wholeday") + ))) + ,@(with-label + "Upprepande?" + `(input (@ (type "checkbox") + (name "has_repeats") + )))) + + ) + + ,@(with-label + "Plats" + `(input (@ (placeholder "Plats") + (name "location") + (type "text") + (data-property "location") + ; (value ,(or (prop ev 'LOCATION) "")) + ))) + + ,@(with-label + "Beskrivning" + `(textarea (@ (placeholder "Beskrivning") + (data-property "description") + (name "description")) + ; ,(prop ev 'DESCRIPTION) + )) + + ,@(with-label + "Kategorier" + `(input-list + (@ (name "categories") + (data-property "categories")) + (input (@ (type "text") + (placeholder "Kattegori"))))) + + ;; TODO This should be a "list" where any field can be edited + ;; directly. Major thing holding us back currently is that + ;; <input-list /> doesn't supported advanced inputs + ;; (div (@ (class "input-list")) + ;; (div (@ (class "unit final newfield")) + ;; (input (@ (type "text") + ;; (list "known-fields") + ;; (placeholder "Nytt fält"))) + ;; (select (@ (name "TYPE")) + ;; (option (@ (value "TEXT")) "Text")) + ;; (span + ;; (input (@ (type "text") + ;; (placeholder "Värde")))))) + + ;; (hr) + + + (input (@ (type "submit"))) + )))) + +;; description in sidebar / tab of popup +;; Template data for <vevent-description /> +(define-public (description-template) + '(template + (@ (id "vevent-description")) + (div (@ (class " vevent eventtext summary-tab " ())) + (h3 ((span (@ (class "repeating")) + "↺") + (span (@ (class "summary") + (data-property "summary"))))) + (div (div (time (@ (class "dtstart") + (data-property "dtstart") + (data-fmt "~L~H:~M") + (datetime ; "2021-09-29T19:56:46" + )) + ; "19:56" + ) + "\xa0—\xa0" + (time (@ (class "dtend") + (data-property "dtend") + (data-fmt "~L~H:~M") + (datetime ; "2021-09-29T19:56:46" + )) + ; "20:56" )) - '(freq until count interval bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - wkst) - ; (prop event 'RRULE) - )))) - - -(define-public (popup ev 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")) - ,(btn "×" - title: "Stäng" - onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))" - class: '("close-tooltip")) - ,(when (edit-mode) - (list - (btn "🖊️" - title: "Redigera" - onclick: "place_in_edit_mode(event_from_popup(this.closest('.popup-container')))") - (btn "🗑" - title: "Ta bort" - onclick: "remove_event(event_from_popup(this.closest('.popup-container')))")))) - - ,(tabset - `(("📅" title: "Översikt" - ,(fmt-single-event ev)) - - ,@(when (edit-mode) - `(("📅" title: "Redigera" - ,(fmt-for-edit ev)))) - - ,@(when (debug) - `(("🐸" title: "Debug" - (div - (pre ,(prop ev 'UID)))))) - - ("⤓" title: "Nedladdning" - (div (@ (class "eventtext") (style "font-family:sans")) - (h2 "Ladda ner") - (div (@ (class "side-by-side")) - (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) - "som iCal")) - (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) - "som xCal"))) - ,@(when (debug) - `((ul - (li (button (@ (onclick "console.log(event_to_jcal(event_from_popup(this.closest('.popup-container'))));")) "js")) - (li (button (@ (onclick "console.log(jcal_to_xcal(event_to_jcal(event_from_popup(this.closest('.popup-container')))));")) "xml")) - (li (button (@ (onclick "console.log(event_from_popup(this.closest('.popup-container')))")) "this")) - )))) - )) - - ,@(when (prop ev 'RRULE) - `(("↺" title: "Upprepningar" class: "repeating" - ,(editable-repeat-info ev))))))))) + (div (@ (class "fields")) + (div (b "Plats: ") + (div (@ (class "location") + (data-property "location")) + ; "Alsättersgatan 13" + )) + (div (@ (class "description") + (data-property "description")) + ; "With a description" + ) + + (div (@ (class "categories") + (data-property "categories"))) + ;; (div (@ (class "categories")) + ;; (a (@ (class "category") + ;; (href "/search/?" + ;; "q=%28member%20%22test%22%20%28or%20%28prop%20event%20%28quote%20CATEGORIES%29%29%20%28quote%20%28%29%29%29%29")) + ;; test)) + ;; (div (@ (class "rrule")) + ;; "Upprepas " + ;; "varje vecka" + ;; ".") + (div (@ (class "last-modified")) + "Senast ändrad -" + ; "2021-09-29 19:56" + )))))) + +(define-public (vevent-edit-rrule-template) + `(template + (@ (id "vevent-edit-rrule")) + (div (@ (class "eventtext")) + (h2 "Upprepningar") + (dl + (dt "Frequency") + (dd (select (@ (name "freq")) + (option "-") + ,@(map (lambda (x) `(option (@ (value ,x)) ,(string-titlecase (symbol->string x)))) + '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)))) + + (dt "Until") + (dd (date-time-input (@ (name "until")))) + + (dt "Conut") + (dd (input (@ (type "number") (name "count") (min 0)))) + + (dt "Interval") + (dd (input (@ (type "number") (name "interval") ; min and max depend on FREQ + ))) + + ,@(concatenate + (map (lambda (pair) + (define name (list-ref pair 0)) + (define pretty-name (list-ref pair 1)) + (define min (list-ref pair 2)) + (define max (list-ref pair 3)) + `((dt ,pretty-name) + (dd (input-list (@ (name ,name)) + (input (@ (type "number") + (min ,min) (max ,max))))))) + '((bysecond "By Second" 0 60) + (byminute "By Minute" 0 59) + (byhour "By Hour" 0 23) + (bymonthday "By Month Day" -31 31) ; except 0 + (byyearday "By Year Day" -366 366) ; except 0 + (byweekno "By Week Number" -53 53) ; except 0 + (bymonth "By Month" 1 12) + (bysetpos "By Set Position" -366 366) ; except 0 + ))) + + ;; (dt "By Week Day") + ;; (dd (input-list (@ (name "byweekday")) + ;; (input (@ (type number) + ;; (min -53) (max 53) ; except 0 + ;; )) + ;; ,(week-day-select '()) + ;; )) + + (dt "Weekstart") + (dd ,(week-day-select '((name "wkst"))))))) + ) + + +;; Based on popup:s output +(define-public (popup-template) + `(template + (@ (id "popup-template")) + ;; becomes the direct child of <popup-element/> + (div (@ (class "popup-root window") + (onclick "event.stopPropagation()")) + + (nav (@ (class "popup-control")) + (button (@ (class "close-button") + (title "Stäng") + (aria-label "Close")) + "×") + (button (@ (class "maximize-button") + (title "Fullskärm") + ;; (aria-label "") + ) + "🗖") + (button (@ (class "remove-button") + (title "Ta Bort")) + "🗑")) + + (tab-group (@ (class "window-body")) + (vevent-description + (@ (data-label "📅") (data-title "Översikt") + (class "vevent"))) + + (vevent-edit + (@ (data-label "🖊") (data-title "Redigera"))) + + ;; (vevent-edit-rrule + ;; (@ (data-label "↺") (data-title "Upprepningar"))) + + (vevent-changelog + (@ (data-label "📒") (date-title "Changelog"))) + + ,@(when (debug) + '((vevent-dl + (@ (data-label "🐸") (data-title "Debug"))))))))) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 4574f517..aa311fcb 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -8,11 +8,11 @@ :use-module (datetime) :use-module (calp html components) :use-module ((calp html vcomponent) - :select (popup - calendar-styles + :select (calendar-styles fmt-day make-block fmt-single-event + output-uid )) :use-module (calp html config) :use-module (calp html util) @@ -25,8 +25,10 @@ :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) + :use-module ((vcomponent recurrence) :select (repeating? generate-recurrence-set)) :use-module ((vcomponent group) :select (group-stream get-groups-between)) + :use-module ((base64) :select (base64encode)) ) @@ -48,7 +50,10 @@ (define*-public (html-generate key: (intervaltype 'all) ; 'week | 'month | 'all - calendars events start-date end-date + calendars ; All calendars to work on, probably (get-calendars global-event-object) + events ; All events which can be worked on, probably (get-event-set global-event-object) + start-date ; First date in interval to show + end-date ; Last date in interval to show render-calendar ; (bunch of kv args) → (list sxml) next-start ; date → date prev-start ; date → date @@ -93,7 +98,14 @@ (meta (@ (name end-time) (content ,(date->string (date+ end-date (date day: 1)) "~s")))) - (script "EDIT_MODE=" ,(if (edit-mode) "true" "false") ";") + (script + ,(format #f + " +EDIT_MODE=~:[false~;true~]; +window.default_calendar='~a';" + (edit-mode) + (base64encode (get-config 'default-calendar)))) + (style ,(format #f "html { --editmode: 1.0; @@ -104,19 +116,8 @@ ,(include-alt-css "/static/dark.css" '(title "Dark")) ,(include-alt-css "/static/light.css" '(title "Light")) - (script (@ (defer) (src "/static/types.js"))) - (script (@ (defer) (src "/static/lib.js"))) - (script (@ (defer) (src "/static/jcal.js"))) - (script (@ (defer) (src "/static/dragable.js"))) - (script (@ (defer) (src "/static/clock.js"))) - (script (@ (defer) (src "/static/popup.js"))) - (script (@ (defer) (src "/static/rrule.js"))) - (script (@ (defer) (src "/static/binders.js"))) - (script (@ (defer) (src "/static/server_connect.js"))) - (script (@ (defer) (src "/static/input_list.js"))) - (script (@ (defer) (src "/static/date_time.js"))) - (script (@ (defer) (src "/static/vcal.js"))) - (script (@ (defer) (src "/static/script.js"))) + (script (@ (src "/static/script.out.js"))) + ,(calendar-styles calendars) ,@(when (debug) @@ -136,6 +137,10 @@ next-start: next-start prev-start: prev-start ) + + ,(btn onclick: "addNewEvent()" + "+") + ;; Popups used to be here, but was moved into render-calendar so each ;; sub-view can itself decide where to put them. This is important ;; since they need to be placed as children to the scrolling @@ -146,6 +151,7 @@ (footer (@ (style "grid-area: footer")) (span "Page generated " ,(date->string (current-date))) + (span "Current time " (current-time (@ (interval 1)))) (span (a (@ (href ,(repo-url))) "Source Code"))) @@ -162,13 +168,14 @@ ,(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")) + (today-button + (a (@ (class "btn") + (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 @@ -248,32 +255,22 @@ (summary "Calendar list") (ul ,@(map (lambda (calendar) - `(li (@ (class "CAL_" - ,(html-attr (prop calendar 'NAME)))) + `(li (@ (data-calendar ,(base64encode (prop calendar 'NAME)))) (a (@ (href "/search?" - ,((@ (web uri-query) encode-query-parameters) - `((q . (and (date/-time<=? - ,(current-datetime) - (prop event 'DTSTART)) - ;; TODO this seems to miss some calendars, - ;; I belive it's due to some setting X-WR-CALNAME, - ;; which is only transfered /sometimes/ into NAME. - (string=? ,(->string (prop calendar 'NAME)) - (or (prop (parent event) 'NAME) "")))))))) + ,((@ (web uri-query) encode-query-parameters) + `((q . (and (date/-time<=? + ,(current-datetime) + (prop event 'DTSTART)) + ;; TODO this seems to miss some calendars, + ;; I belive it's due to some setting X-WR-CALNAME, + ;; which is only transfered /sometimes/ into NAME. + (string=? ,(->string (prop calendar 'NAME)) + (or (prop (parent event) 'NAME) "")))))))) ,(prop calendar 'NAME)))) 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))) - ))) + ;; (div (@ (id "calendar-dropdown-template") (class "template")) + ;; ) + )) ;; List of events (div (@ (class "eventlist") @@ -286,7 +283,11 @@ ;; Figure out way to merge it with the below call. ,@(stream->list (stream-map - fmt-single-event + (lambda (ev) + (fmt-single-event + ev `((id ,(html-id ev)) + (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) + "unknown")))))) (stream-take-while (compose (cut date/-time<? <> start-date) (extract 'DTSTART)) @@ -296,32 +297,40 @@ ;; 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: "" - ;; 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 - ;; dosen't matter - (data-start "2020-01-01") - (data-end "2020-01-02")) - ,(caddar ; strip <a> tag - (make-block event `((class " generated "))))) - ;; TODO merge this into the event-set, add attribute - ;; for non-displaying elements. - (div (@ (class "template") (id "popup-template")) - ,(popup event (string-append "popup" (html-id event)))))) + ;; ,@(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: "" + ;; ;; 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 + ;; ;; ;; dosen't matter + ;; ;; (data-start "2020-01-01") + ;; ;; (data-end "2020-01-02")) + ;; ;; ,(caddar ; strip <a> tag + ;; ;; (make-block event `((class " generated "))))) + ;; ;; TODO merge this into the event-set, add attribute + ;; ;; for non-displaying elements. + ;; ;; (div (@ (class "template") (id "popup-template")) + ;; ;; ,(popup event (string-append "popup" (html-id event)))) + ;; )) + + ;;; Templates used by our custom components + ,((@ (calp html vcomponent) edit-template) calendars) + ,((@ (calp html vcomponent) description-template)) + ,((@ (calp html vcomponent) vevent-edit-rrule-template)) + ,((@ (calp html vcomponent) popup-template)) ;; Auto-complets when adding new fields to a component ;; Any string is however still valid. @@ -344,4 +353,59 @@ RDATE RRULE ACTION REPEAT TRIGGER CREATED DTSTAMP LAST-MODIFIED SEQUENCE REQUEST-STATUS - )))))) + ))) + + ,@(let* ( + (flat-events + ;; A simple filter-sorted-stream on event-overlaps? here fails. + ;; See tests/annoying-events.scm + (stream->list + (stream-filter + (lambda (ev) + ((@ (vcomponent datetime) event-overlaps?) + ev pre-start + (date+ post-end (date day: 1)))) + (stream-take-while (lambda (ev) (date< + (as-date (prop ev 'DTSTART)) + (date+ post-end (date day: 1)))) + events)))) + (repeating% regular (partition repeating? flat-events)) + (repeating + (for ev in repeating% + (define instance (copy-vcomponent ev)) + + (set! (prop instance 'UID) (output-uid instance)) + (delete-parameter! (prop* instance 'DTSTART) '-X-HNH-ORIGINAL) + (delete-parameter! (prop* instance 'DTEND) '-X-HNH-ORIGINAL) + + instance))) + + `( + ;; Mapping showing which events belongs to which calendar, + ;; on the form + ;; (calendar (@ (key ,(base64-encode calendar-name))) + ;; (li ,event-uid) ...) + (div (@ (style "display:none !important;") + (id "calendar-event-mapping")) + ,(let ((ht (make-hash-table))) + (for-each (lambda (event) + (define name (prop (parent event) 'NAME)) + (hash-set! ht name + (cons (prop event 'UID) + (hash-ref ht name '())))) + (append regular repeating)) + + (hash-map->list + (lambda (key values) + `(calendar (@ (key ,(base64encode key))) + ,@(map (lambda (uid) `(li ,uid)) + values))) + ht))) + + ;; Calendar data for all events in current interval, + ;; rendered as xcal. + (div (@ (style "display:none !important;") + (id "xcal-data")) + ,((@ (vcomponent xcal output) ns-wrap) + (map (@ (vcomponent xcal output) vcomponent->sxcal) + (append regular repeating))))))))) diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index 0ac69292..02689fd5 100644 --- a/module/calp/html/view/calendar/month.scm +++ b/module/calp/html/view/calendar/month.scm @@ -11,7 +11,7 @@ :select (really-long-event? events-between)) :use-module ((calp html vcomponent) - :select (make-block)) + :select (make-block output-uid)) :use-module ((vcomponent group) :select (group-stream get-groups-between)) ) @@ -35,7 +35,7 @@ (events-between s e (list->stream long-events))))) (date-range pre-start post-end (date day: 7)))) - `((script "const VIEW='month';") + `((script "window.VIEW='month';") (header (@ (class "table-head")) ,(string-titlecase (date->string start-date "~B ~Y"))) (div (@ (class "caltable") @@ -77,11 +77,26 @@ (repeating-naturals 1 7) ))) - ;; These popups are relative the document root. Can thus be placed anywhere in the DOM. + ;; These popups are relative the document root. + ;; Can thus be placed anywhere in the DOM. ,@(for event in (stream->list - (events-between start-date end-date events)) - ((@ (calp html vcomponent) popup) event - (string-append "popup" ((@ (calp html util) html-id) event)))) + (events-between pre-start post-end events)) + `(popup-element + (@ (class "vevent") + (data-uid ,(output-uid event))))) + + (template + (@ (id "vevent-block")) + ;; TODO this is more or less copied verbatim from week's + ;; version, warts and all. Figure out what should and shouldn't + ;; be shared between the two. + (div (@ (data-calendar "unknown")) + (div (@ (class "event-body")) + (span (@ (class "repeating"))) + (span (@ (class "summary") + (data-property "summary"))) + (span (@ (class "location") + (data-property "location")))))) )) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 556c3d85..499de1d6 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -2,6 +2,7 @@ :use-module (calp util) :use-module (srfi srfi-1) :use-module (srfi srfi-41) + :use-module (rnrs records syntactic) :use-module (datetime) :use-module (calp html view calendar shared) :use-module (calp html config) @@ -13,16 +14,18 @@ event-zero-length? events-between)) :use-module ((calp html vcomponent) - :select (make-block) ) + :select (make-block output-uid) ) + ;; :use-module ((calp html components) + ;; :select ()) :use-module ((vcomponent group) :select (group-stream get-groups-between)) ) -(define*-public (render-calendar key: events start-date end-date #:allow-other-keys) +(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 "const VIEW='week';") + `((script "window.VIEW='week';") (div (@ (class "calendar")) (div (@ (class "days")) ;; Top left area @@ -52,10 +55,54 @@ ,@(for event in (stream->list (events-between start-date end-date events)) - ((@ (calp html vcomponent ) popup) event (string-append "popup" (html-id event)))) - - ))))) - + `(popup-element + (@ (class "vevent") + (data-uid ,(output-uid event))))))) + + + ;; This template is here, instead of in (calp html calendar) since it only + ;; applies to this specific view. (calp html calendar month) is assumed to + ;; have its own variant of it. + (template (@ (id "vevent-block")) + ,(block-template) + ) + + +))) + + +;; "physical" block +(define (block-template) + `(div (@ ; (id ,(html-id ev)) + (data-calendar "unknown") + #; + (class " CAL_unknown" + ;; ,(when (and (prop ev 'PARTSTAT) + ;; (eq? 'TENTATIVE (prop ev 'PARTSTAT))) + ;; " tentative") + ;; ,(when (and (prop ev 'TRANSP) + ;; (eq? 'TRANSPARENT (prop ev 'TRANSP))) + ;; " transparent") + ) + ; (onclick "toggle_popup('popup' + this.id)") + ) + ;; Inner div to prevent overflow. Previously "overflow: none" + ;; was set on the surounding div, but the popup /needs/ to + ;; overflow (for the tabs?). + (div (@ (class "event-body")) + (span (@ (class "repeating")) ; "↺" + ) + (span (@ (class "summary") + (data-property "summary")) + ; ,(format-summary ev (prop ev 'SUMMARY)) + ) + (span (@ (class "location") + (data-property "location"))) + ;; Document symbol when we have text + (span (@ (class "description")) + ; "🗎" + )) + ) ) (define (time-marker-div) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index b024ed4f..08e48714 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -20,7 +20,7 @@ :use-module ((rnrs io ports) :select (get-bytevector-all)) :use-module ((xdg basedir) :prefix xdg-) - :use-module ((calp html util) :select (html-unattr)) + :use-module ((base64) :select (base64decode)) :use-module (web http make-routes) @@ -58,7 +58,12 @@ [else "🙃"])) (td (a (@ (href "/" ,dir "/" ,k)) ,k)) (td ,(number->string (stat:perms stat) 8))))) - (cdr (scandir dir)))))) + (cdr (or (scandir dir) + (scm-error + 'misc-error + "directory-table" + "Scandir argument invalid or not directory: ~a" + (list dir) '()))))))) @@ -162,8 +167,7 @@ (format #f "No event with UID '~a'" uid)))) ;; TODO this fails when dtstart is <date>. - ;; @var{cal} should be the name of the calendar encoded with - ;; modified base64. See (calp html util). + ;; @var{cal} should be the name of the calendar encoded in base64. (POST "/insert" (cal data) (unless (and cal data) @@ -174,7 +178,7 @@ ;; NOTE that this leaks which calendar exists, ;; but you can only query for existance. ;; also, the calendar view already show all calendars. - (let* ((calendar-name (html-unattr cal)) + (let* ((calendar-name (base64decode cal)) (calendar (find (lambda (c) (string=? calendar-name (prop c 'NAME))) (get-calendars global-event-object)))) diff --git a/module/calp/util.scm b/module/calp/util.scm index 06767658..96ca2f01 100644 --- a/module/calp/util.scm +++ b/module/calp/util.scm @@ -9,7 +9,6 @@ set/r! catch-multiple quote? - re-export-modules -> ->> set set-> aif awhen let-lazy let-env case* define-many @@ -298,19 +297,10 @@ (define-public (as-symb s) (if (string? s) (string->symbol s) s)) - - (define-public (enumerate lst) (zip (iota (length lst)) lst)) -;; Map with index -(define-syntax-rule (map-each proc lst) - (map (lambda (x i) (proc x i)) - lst (iota (length lst)))) - -(export map-each) - ;; Takes a procedure returning multiple values, and returns a function which ;; takes the same arguments as the original procedure, but only returns one of ;; the procedures. Which procedure can be sent as an additional parameter. @@ -339,14 +329,6 @@ (cons (proc (car dotted-list)) (map/dotted proc (cdr dotted-list)))))) -(define-syntax re-export-modules - (syntax-rules () - ((_ (mod ...) ...) - (begin - (module-use! (module-public-interface (current-module)) - (resolve-interface '(mod ...))) - ...)))) - ;; Merges two association lists, comparing with eq. ;; The cdrs in all pairs in both lists should be lists, ;; If a key is present in both then the contents of b is @@ -380,7 +362,7 @@ ;; NOTE changing this list to cons allows the output to work with assq-merge. (hash-map->list list h))) -;; (group-by '(0 1 2 3 4 2 5 6) 2) +;; (split-by '(0 1 2 3 4 2 5 6) 2) ;; ⇒ ((0 1) (3 4) (5 6)) (define-public (split-by list item) (let loop ((done '()) @@ -523,6 +505,21 @@ (call-with-values (lambda () (apply proc args)) list)) lists))) +(define (ass%-ref-all alist key =) + (map cdr (filter (lambda (pair) (= key (car pair))) + alist))) + +;; Equivalent to assoc-ref (and family), but works on association lists with +;; non-unique keys, returning all mathing records (instead of just the first). +;; @begin lisp +;; (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a) +;; ⇒ (1 3) +;; @end +(define-public (assoc-ref-all alist key) (ass%-ref-all alist key equal?)) +(define-public (assq-ref-all alist key) (ass%-ref-all alist key eq?)) +(define-public (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) + + (define-public (vector-last v) @@ -536,6 +533,10 @@ (define-public (->quoted-string any) (with-output-to-string (lambda () (write any)))) + + + +;; TODO shouldn't this use `file-name-separator-string'? (define-public (path-append . strings) (fold (lambda (s done) (string-append @@ -554,6 +555,7 @@ +;;; TODO shouldn't this use dynamic-wind? To handle non-local exits? (define-syntax let-env (syntax-rules () [(_ ((name value) ...) |