diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-23 01:39:08 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-23 01:39:08 +0200 |
commit | 327b322b9583f760cd02ddad7a2a8890df26cc8b (patch) | |
tree | d0a73d5df0011233f3eaa5d9a54d1317fad50bbc /module/c | |
parent | Minor cleanup in recurrence generate. (diff) | |
download | calp-327b322b9583f760cd02ddad7a2a8890df26cc8b.tar.gz calp-327b322b9583f760cd02ddad7a2a8890df26cc8b.tar.xz |
workuid-stuff-2
Diffstat (limited to '')
-rw-r--r-- | module/calp/html/vcomponent.scm | 36 | ||||
-rw-r--r-- | module/calp/html/view/calendar.scm | 128 | ||||
-rw-r--r-- | module/calp/html/view/calendar/month.scm | 7 | ||||
-rw-r--r-- | module/calp/html/view/calendar/week.scm | 7 | ||||
-rw-r--r-- | module/calp/server/routes.scm | 67 |
5 files changed, 157 insertions, 88 deletions
diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 1cee47a5..472a8c2b 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -112,7 +112,9 @@ (class ,(when (and (prop ev 'PARTSTAT) (eq? 'TENTATIVE (prop ev 'PARTSTAT))) " tentative ")) - (data-uid ,(output-uid ev))))) + ,@(when (repeating? ev) + `((data-instance ,(datetime->string (as-datetime (prop ev 'DTSTART)))))) + (data-uid ,(prop ev 'UID))))) (div (@ (class "vevent eventtext summary-tab")) (h3 ,(fmt-header (when (prop ev 'RRULE) @@ -293,7 +295,10 @@ extra-attributes `((id ,(html-id ev) "-block") (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) "unknown"))) - (data-uid ,(output-uid ev)) + (data-uid ,(prop ev 'UID)) + ;; TODO write helper for this (re-occuring) case + ,@(when (repeating? ev) + `((data-instance ,(datetime->string (as-datetime (prop ev 'DTSTART)))))) (class "vevent event" ,(when (and (prop ev 'PARTSTAT) @@ -352,29 +357,6 @@ (prop event 'RRULE))))) -;; 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 "-") @@ -476,7 +458,9 @@ ;; (hr) - (input (@ (type "submit"))) + (input (@ (type "submit") (data-key "this") (value "This"))) + (input (@ (type "submit") (data-key "this_future") (value "This & Future"))) + (input (@ (type "submit") (data-key "all") (value "All"))) )))) ;; description in sidebar / tab of popup diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 8b7d8075..9e2992a4 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -2,7 +2,7 @@ :use-module (hnh util) :use-module (vcomponent) :use-module ((vcomponent datetime) - :select (events-between)) + :select (ev-time<? events-between)) :use-module (datetime) :use-module (calp html components) :use-module ((calp html vcomponent) @@ -10,7 +10,6 @@ fmt-day make-block fmt-single-event - output-uid )) :use-module (calp html config) :use-module (calp html util) @@ -29,8 +28,14 @@ :select (group-stream get-groups-between)) :use-module ((base64) :select (base64encode)) + :use-module ((vcomponent util instance) :select (global-event-object)) + :use-module ((vcomponent util instance methods) :select (fixed-events-in-range + repeating-events-in-range)) + :use-module (ice-9 format) :use-module (calp translation) + :use-module ((vcomponent formats xcal output) + :select (vcomponent->sxcal)) ) @@ -46,6 +51,35 @@ (define repo-url (make-parameter "https://git.hornquist.se/calp")) +;; Mapping showing which events belongs to which calendar, +;; on the form +;; (calendar (@ (key ,(base64-encode calendar-name))) +;; (li ,event-uid) ...) +(define (calendar-event-mapping events) + `(div (@ (style "display:none !important;") + (id "calendar-event-mapping")) + + ;; ,(for (calendar entries ...) in (group-by parent events) + ;; `(calendar (@ (key ,(base64encode (prop calendar 'NAME)))) + ;; ,@(map (lambda (uid) `(li ,uid)) + ;; (map (extract 'UID) entries)))) + + ,(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 '())))) + events) + + (hash-map->list + (lambda (key values) + `(calendar (@ (key ,(base64encode key))) + ,@(map (lambda (uid) `(li ,uid)) + values))) + ht)))) + + ;; TODO document what @var{render-calendar} is supposed to take and return. ;; Can at least note that @var{render-calendar} is strongly encouraged to include ;; (script "const VIEW='??';"), where ?? is replaced by the name of the view. @@ -362,57 +396,39 @@ window.default_calendar='~a';" 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 formats xcal output) ns-wrap) - (map (@ (vcomponent formats xcal output) vcomponent->sxcal) - (append regular repeating))))))))) + ,(let ((regular (fixed-events-in-range global-event-object start-date end-date)) + (repeating (repeating-events-in-range global-event-object start-date end-date))) + + `(div (@ (style "display:none !important")) + ,(calendar-event-mapping (append regular repeating)) + + ;; Calendar data for all events in current interval, + ;; rendered as xcal. + (div (@ (id "xcal-data")) + ,((@ (vcomponent formats xcal output) ns-wrap) + (map vcomponent->sxcal regular))) + + (div (@ (id "xcal-data-repeating")) + ,((@ (vcomponent formats xcal output) ns-wrap) + (map vcomponent->sxcal + ;; TODO possibly create generate-reccurrence-set-in-interval + (map (lambda (event) + (delete-parameter! (prop* event 'DTSTART) '-X-HNH-ORIGINAL) + (delete-parameter! (prop* event 'DTEND) '-X-HNH-ORIGINAL) + event) + (stream->list + (events-between + start-date end-date + (interleave-streams + ev-time<? + (map generate-recurrence-set repeating))))))) + + ) + ) + + #; + (map (lambda (ev) + (set! (prop ev 'X-HNH-INSTANCE-ID) + (datetime->string (as-datetime (prop ev 'DTSTART)))) + (vcomponent->sxcal ev)) + repeating))))) diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index 1c162aaa..5678db0f 100644 --- a/module/calp/html/view/calendar/month.scm +++ b/module/calp/html/view/calendar/month.scm @@ -12,9 +12,10 @@ :select (really-long-event? events-between)) :use-module ((calp html vcomponent) - :select (make-block output-uid)) + :select (make-block)) :use-module ((vcomponent util group) :select (group-stream get-groups-between)) + :use-module ((vcomponent recurrence) :select (repeating?)) ) ;; (stream event-group) -> sxml @@ -84,7 +85,9 @@ (events-between pre-start post-end events)) `(popup-element (@ (class "vevent") - (data-uid ,(output-uid event))))) + (data-uid ,(prop event 'UID)) + ,@(when (repeating? event) + `((data-instance ,(datetime->string (as-datetime (prop event 'DTSTART))))))))) (template (@ (id "vevent-block")) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 78abcfbf..1303f134 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -15,13 +15,14 @@ event-zero-length? events-between)) :use-module ((calp html vcomponent) - :select (make-block output-uid) ) + :select (make-block) ) ;; :use-module ((calp html components) ;; :select ()) :use-module (calp translation) :use-module ((vcomponent util group) :select (group-stream get-groups-between)) :use-module (ice-9 format) + :use-module ((vcomponent recurrence) :select (repeating?)) ) @@ -62,7 +63,9 @@ (events-between start-date end-date events)) `(popup-element (@ (class "vevent") - (data-uid ,(output-uid event))))))) + ,@(when (repeating? event) + `((data-instance ,(datetime->string (as-datetime (prop event 'DTSTART)))))) + (data-uid ,(prop event 'UID))))))) ;; This template is here, instead of in (calp html calendar) since it only diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 3d90cc04..37111c71 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -32,6 +32,12 @@ :autoload (vcomponent util instance) (global-event-object) + :use-module (vcomponent recurrence) + :use-module ((vcomponent recurrence internal) :select (until)) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (hnh util uuid) + :use-module (calp util config) :use-module (calp html view calendar) :use-module ((calp html view search) :select (search-result-page)) @@ -207,7 +213,7 @@ ;; TODO this fails when dtstart is <date>. ;; @var{cal} should be the name of the calendar encoded in base64. - (POST "/insert" (cal data) + (POST "/insert" (cal data submit_type) (unless (and cal data) (return (build-response code: 400) @@ -269,8 +275,65 @@ (parameterize ((warnings-are-errors #t)) (catch* - (lambda () (add-and-save-event global-event-object + (lambda () + (if (repeating? event) + (cond + ((not (string? submit_type)) + (scm-error 'wrong-type-arg #f + "Expected string, got ~s" (list submit_type) #f) + ) + ((string=? submit_type "this") + ;; Change this instance only + ;; set EXDATE + (string->datetime (prop event 'X-HNH-INSTANCE-ID)) + ) + ;; change this and future instances + ((string=? submit_type "this_future") + ;; mark original event's RRULE with until this event + ;; create new event, which should be really similar + (let* ((og-event (get-event-by-uid global-event-object (prop event 'UID))) + (occurences (generate-recurrence-set og-event)) + (pairs (stream-zip occurences (stream-cdr occurences))) + (dt (string->datetime (prop event 'X-HNH-INSTANCE-ID)))) + ;; find recurrence instance before this one + (let ((last-of-old-instances + (car + (stream-find (lambda (p) (datetime= dt (cadr (prop p 'DTSTART)))) + pairs)))) + (let ((event-a event) + (event-b (copy-vcomponent event))) + (set! + (prop event-a 'RRULE) + (set-> (prop og-event 'RRULE) + (until (prop last-of-old-instances 'DTSTART))) + (prop event-a 'DTSTART) (prop og-event 'DTSTART) + (prop event-a 'DTEND) (prop og-event 'DTEND) + (prop event-b 'UID) (uuid) + ) + ) + )) + ;; use its date as UNTIL in RRULE + ) + ((string=? submit_type "all") + ;; change all instances + (let ((og-event (get-event-by-uid global-event-object (prop event 'UID)))) + (set! + (prop event 'DTSTART) + (datetime date: (as-date (prop og-event 'DTSTART)) + time: (as-time (prop event 'DTSTART))) + (prop event 'DTEND) + (datetime date: (as-date (prop og-event 'DTEND)) + time: (as-time (prop event 'DTEND)))) + (add-and-save-event global-event-object + calendar event))) + (else + (scm-error 'misc-error #f + "Invalid submit_type: ~s" + (list submit_type) #f))) + ;; else (if not repeating) + (add-and-save-event global-event-object calendar event)) + ) (warning (lambda (err fmt args) (define str (format #f "~?" fmt args)) |