aboutsummaryrefslogtreecommitdiff
path: root/module/calp
diff options
context:
space:
mode:
Diffstat (limited to 'module/calp')
-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
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))
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-19 17:25:32 +0200