aboutsummaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/calp/html/vcomponent.scm36
-rw-r--r--module/calp/html/view/calendar.scm128
-rw-r--r--module/calp/html/view/calendar/month.scm7
-rw-r--r--module/calp/html/view/calendar/week.scm7
-rw-r--r--module/calp/server/routes.scm67
-rw-r--r--module/vcomponent/util/instance/methods.scm110
6 files changed, 224 insertions, 131 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))
diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm
index 7a1d2fc8..6bafb274 100644
--- a/module/vcomponent/util/instance/methods.scm
+++ b/module/vcomponent/util/instance/methods.scm
@@ -10,10 +10,12 @@
;; :use-module (vcomponent parse)
:use-module ((vcomponent util parse-cal-path) :select (parse-cal-path))
:use-module ((vcomponent recurrence) :select (generate-recurrence-set repeating?))
- :use-module ((vcomponent datetime) :select (ev-time<?))
+ :use-module ((vcomponent datetime) :select (ev-time<? event-overlaps?))
:use-module (oop goops)
:use-module (calp translation)
+ :use-module ((vcomponent recurrence internal) :select (until count)
+ :renamer (symbol-prefix-proc (symbol #\r #\r #\:)))
:export (add-event
remove-event
@@ -22,6 +24,7 @@
get-event-by-uid
fixed-events-in-range
+ repeating-events-in-range
get-calendar-by-name
@@ -60,6 +63,7 @@
(define (make-instance calendar-files)
(make <events> calendar-files: calendar-files))
+
(define-method (get-event-by-uid (this <events>) uid)
(hash-ref (slot-ref this 'uid-map) uid))
@@ -70,10 +74,24 @@
(define-method (fixed-events-in-range (this <events>) start end)
+ ;; TODO why not use events-between here?
(filter-sorted (lambda (ev) ((in-date-range? start end)
(as-date (prop ev 'DTSTART))))
(slot-ref this 'fixed-events)))
+(define-method (repeating-events-in-range (this <events>) start end)
+ (filter (lambda (ev)
+ (cond ((date/-time< end (prop ev 'DTSTART)) #f)
+ ((and=> (prop ev 'RRULE) rr:until) => (lambda (u) (date/-time< u start)))
+ ((prop ev 'RRULE)
+ => (lambda (rr)
+ (or (not (or (rr:until rr) (rr:count rr)))
+ ;; else if recurrence set overlaps interval
+ ;; TODO check this with tests/annoying-events.scm
+ (stream-find (lambda (instance) (event-overlaps? instance start end))
+ (generate-recurrence-set ev)))))))
+ (slot-ref this 'repeating-events)))
+
(define-method (initialize (this <events>) args)
(next-method)
@@ -85,6 +103,7 @@
(let ((calendars (load-calendars (slot-ref this 'calendar-files))))
(apply add-calendars this calendars)))
+
(define-method (add-calendars (this <events>) . calendars)
(slot-set! this 'calendars (append calendars (slot-ref this 'calendars)))
@@ -166,61 +185,66 @@
(prop event 'UID)))
(slot-ref this 'event-set)))
- (hash-set! (slot-ref this 'uid-map) (prop event 'UID)
- #f))
+ (remove-child! (parent event) event)
+ (hash-remove! (slot-ref this 'uid-map) (prop event 'UID)))
-(define-method (add-and-save-event (this <events>) calendar event)
- (cond
- [(get-event-by-uid this (prop event 'UID))
- => (lambda (old-event)
+(define-method (update-and-save-event (this <events>) calendar old-event)
+ ;; remove old instance of event from runtime
+ (remove-event this old-event)
- ;; remove old instance of event from runtime
- (remove-event this old-event)
- (remove-child! (parent old-event) old-event)
+ ;; Add new event to runtime,
+ ;; MUST be done after since the two events SHOULD share UID.
+ ;; NOTE that this can emit warnings
+ (add-event this calendar old-event)
+ (remove-child! (parent old-event) old-event)
- ;; Add new event to runtime,
- ;; MUST be done after since the two events SHOULD share UID.
- ;; NOTE that this can emit warnings
- (add-event this calendar event)
+ (set! (prop old-event 'LAST-MODIFIED)
+ (current-datetime))
- (set! (prop event 'LAST-MODIFIED)
- (current-datetime))
+ ;; NOTE Posibly defer save to a later point.
+ ;; That would allow better asyncronous preformance.
- ;; NOTE Posibly defer save to a later point.
- ;; That would allow better asyncronous preformance.
+ ;; save-event sets -X-HNH-FILENAME from the UID. This is fine
+ ;; since the two events are guaranteed to have the same UID.
+ (unless ((@ (vcomponent formats vdir save-delete) save-event) old-event)
+ (throw 'misc-error (_ "Saving event to disk failed.")))
- ;; save-event sets -X-HNH-FILENAME from the UID. This is fine
- ;; since the two events are guaranteed to have the same UID.
- (unless ((@ (vcomponent formats vdir save-delete) save-event) event)
- (throw 'misc-error (_ "Saving event to disk failed.")))
+ (unless (eq? calendar (parent old-event))
+ ;; change to a new calendar
+ (format (current-error-port)
+ (_ "Unlinking old event from ~a~%")
+ (prop old-event '-X-HNH-FILENAME))
+ ;; NOTE that this may fail, leading to a duplicate event being
+ ;; created (since we save beforehand). This is just a minor problem
+ ;; which either a better atomic model, or a propper error
+ ;; recovery log would solve.
+ ((@ (vcomponent formats vdir save-delete) remove-event) old-event))
- (unless (eq? calendar (parent old-event))
- ;; change to a new calendar
- (format (current-error-port)
- (_ "Unlinking old event from ~a~%")
- (prop old-event '-X-HNH-FILENAME))
- ;; NOTE that this may fail, leading to a duplicate event being
- ;; created (since we save beforehand). This is just a minor problem
- ;; which either a better atomic model, or a propper error
- ;; recovery log would solve.
- ((@ (vcomponent formats vdir save-delete) remove-event) old-event))
+ (format (current-error-port)
+ (_ "Event updated ~a~%") (prop old-event 'UID)))
- (format (current-error-port)
- (_ "Event updated ~a~%") (prop event 'UID)))]
- [else
- (add-event this calendar event)
+;; Add a new event, which isn't already in the event object
+(define-method (add-new-event (this <events>) calendar event)
+ (add-event this calendar event)
- (set! (prop event 'LAST-MODIFIED) (current-datetime))
+ (set! (prop event 'LAST-MODIFIED) (current-datetime))
- ;; NOTE Posibly defer save to a later point.
- ;; That would allow better asyncronous preformance.
- (unless ((@ (vcomponent formats vdir save-delete) save-event) event)
- (throw 'misc-error (_ "Saving event to disk failed.")))
+ ;; NOTE Posibly defer save to a later point.
+ ;; That would allow better asyncronous preformance.
+ (unless ((@ (vcomponent formats vdir save-delete) save-event) event)
+ (throw 'misc-error (_ "Saving event to disk failed.")))
- (format (current-error-port)
- (_ "Event inserted ~a~%") (prop event 'UID))]))
+ (format (current-error-port)
+ (_ "Event inserted ~a~%") (prop event 'UID))
+ )
+
+(define-method (add-and-save-event (this <events>) calendar event)
+ (cond
+ [(get-event-by-uid this (prop event 'UID))
+ => (lambda (old-event) (update-and-save-event this calendar old-event))]
+ [else (add-new-event this calendar event)]))
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-19 13:43:59 +0200