From 1484155c211fe8452344ffdc501e858706ecbc51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 29 Sep 2021 23:36:21 +0200 Subject: Start rework on js setup. --- module/calp/html/vcomponent.scm | 335 ++++++++++++++++---------------- module/calp/html/view/calendar.scm | 64 +++--- module/calp/html/view/calendar/week.scm | 93 ++++++++- module/vcomponent/vdir/save-delete.scm | 2 +- 4 files changed, 304 insertions(+), 190 deletions(-) (limited to 'module') diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 105c6cc5..4b3e9ec7 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -62,54 +62,56 @@ 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")) + `(vevent-description + (@ ,@(assq-merge + attributes + `( + (class " vevent eventtext summary-tab " + ,(when (and (prop ev 'PARTSTAT) + (eq? 'TENTATIVE (prop ev 'PARTSTAT))) + " tentative ")) + (data-uid ,(prop ev 'UID))))) + (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")) @@ -118,7 +120,7 @@ ,(awhen (prop ev 'DESCRIPTION) `(div (@ (class "bind description") (data-property "description")) - ,(format-description ev it))) + ,(format-description ev it))) ,@(awhen (prop* ev 'ATTACH) ;; attach satisfies @code{vline?} @@ -193,123 +195,127 @@ `(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") + `(vevent-edit (@ (class "vevent") + (data-uid ,(prop ev 'UID))))) + +(define-public (edit-template) + `(div (@ (class " eventtext edit-tab ")) + (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)) + ))) + + (div (@ (class "timeinput")) + + ,@(with-label + "Starttid" + `(div (@ (class "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 + ,@(with-label + "Sluttid" + `(div (@ (class "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") + (name "wholeday") + ; ,@(when (date? start) '((checked))) )))) - (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) - - - (input (@ (type "submit"))) - ))) + ) + + ,@(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" + ;; 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) + + + (input (@ (type "submit"))) + ))) ;; Single event in side bar (text objects) @@ -357,12 +363,12 @@ `((a (@ (href "#" ,(html-id ev)) (class "hidelink")) - (div (@ ,@(assq-merge + (vevent-block (@ ,@(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) + (class "vevent event CAL_" ,(html-attr (or (prop (parent ev) 'NAME) "unknown")) ,(when (and (prop ev 'PARTSTAT) (eq? 'TENTATIVE (prop ev 'PARTSTAT))) @@ -371,6 +377,7 @@ (eq? 'TRANSPARENT (prop ev 'TRANSP))) " transparent") ) + (data-uid ,(prop ev 'UID)) (onclick "toggle_popup('popup' + this.id)") ))) ;; Inner div to prevent overflow. Previously "overflow: none" @@ -391,10 +398,12 @@ ,(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))))))) + ev))) + )))) (define (repeat-info event) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 4574f517..00451984 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -111,12 +111,16 @@ (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/binders.js"))) (script (@ (defer) (src "/static/server_connect.js"))) - (script (@ (defer) (src "/static/input_list.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/vcal.js"))) (script (@ (defer) (src "/static/script.js"))) + (script (@ (defer) (src "/static/globals.js"))) + + ;; on load + ,(calendar-styles calendars) ,@(when (debug) @@ -251,15 +255,15 @@ `(li (@ (class "CAL_" ,(html-attr (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")) @@ -311,17 +315,19 @@ ;; 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 tag - (make-block event `((class " generated "))))) + `( + ;; (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 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)))))) + ;; (div (@ (class "template") (id "popup-template")) + ;; ,(popup event (string-append "popup" (html-id event)))) + )) ;; Auto-complets when adding new fields to a component ;; Any string is however still valid. @@ -344,4 +350,18 @@ RDATE RRULE ACTION REPEAT TRIGGER CREATED DTSTAMP LAST-MODIFIED SEQUENCE REQUEST-STATUS - )))))) + ))) + + (div (@ (style "display:none !important;") + (id "xcal-data")) + ,((@ (vcomponent xcal output) ns-wrap) + (map (@ (vcomponent xcal output) vcomponent->sxcal) + (stream->list + (filter-sorted-stream + (lambda (ev) + ((@ (vcomponent datetime) event-overlaps?) + ev start-date + (date+ end-date (date day: 1)))) + events)))))) + + )) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 556c3d85..340db7d5 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -52,10 +52,95 @@ ,@(for event in (stream->list (events-between start-date end-date events)) - ((@ (calp html vcomponent ) popup) event (string-append "popup" (html-id event)))) - - ))))) - + ((@ (calp html vcomponent ) popup) + event (string-append "popup" (html-id event)))) + + )) + ;; description in sidebar / tab of popup + (template (@ (id "vevent-description")) + ,(description-template) + ) + + ;; edit tab of popup + (template (@ (id "vevent-edit")) + ,((@ (calp html vcomponent) edit-template))) + + ;; "physical" block + (template (@ (id "vevent-block")) + ,(block-template) + ) + + ))) + +;; based on the output of fmt-single-event +(define (description-template) + '(div (@ (class " eventtext summary-tab " ())) + (h3 ((span (@ (class "repeating")) "↺") + (span (@ (class "bind summary") + (data-property "summary")) + "Test"))) + (div (div (time (@ (class "bind dtstart") + (data-property "dtstart") + (data-fmt "~L~H:~M") + (datetime "2021-09-29T19:56:46")) + "19:56") + "\xa0—\xa0" + (time (@ (class "bind dtend") + (data-property "dtend") + (data-fmt "~L~H:~M") + (datetime "2021-09-29T19:56:46")) + "20:56")) + (div (@ (class "fields")) + (div (b "Plats: ") + (div (@ (class "bind location") + (data-property "location")) + "Alsättersgatan 13")) + (div (@ (class "bind description") + (data-property "description")) + ("With a description")) + (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 (block-template) + `(div (@ ; (id ,(html-id ev)) + (data-calendar "unknown") + (class "event 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 "bind summary") + (data-property "summary")) + ; ,(format-summary ev (prop ev 'SUMMARY)) + ) + `(span (@ (class "bind location") + (data-property "location"))) + ;; Document symbol when we have text + `(span (@ (class "description")) + ; "🗎" + )) + ) ) (define (time-marker-div) diff --git a/module/vcomponent/vdir/save-delete.scm b/module/vcomponent/vdir/save-delete.scm index d17b595e..b3c7f9c5 100644 --- a/module/vcomponent/vdir/save-delete.scm +++ b/module/vcomponent/vdir/save-delete.scm @@ -11,7 +11,7 @@ (define-module (vcomponent vdir save-delete) :use-module (calp util) - :use-module ((calp util exceptions) :select (assert)) + :use-module ((calp util exceptions) :select (assert)) :use-module (vcomponent ical output) :use-module (vcomponent) :use-module ((calp util io) :select (with-atomic-output-to-file)) -- cgit v1.2.3