diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-07-04 01:58:52 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-07-07 13:10:38 +0200 |
commit | 27884c59318895bdaf9073944eb7e2037875ec0b (patch) | |
tree | 15f9d508fe67d9d738a692588cdca13535eb091f | |
parent | Add insert-ordered. (diff) | |
download | calp-27884c59318895bdaf9073944eb7e2037875ec0b.tar.gz calp-27884c59318895bdaf9073944eb7e2037875ec0b.tar.xz |
Add live import of event.
Diffstat (limited to '')
-rw-r--r-- | module/entry-points/import.scm | 4 | ||||
-rw-r--r-- | module/entry-points/server.scm | 2 | ||||
-rw-r--r-- | module/vcomponent.scm | 51 |
3 files changed, 42 insertions, 15 deletions
diff --git a/module/entry-points/import.scm b/module/entry-points/import.scm index cc67b448..3fa20055 100644 --- a/module/entry-points/import.scm +++ b/module/entry-points/import.scm @@ -49,7 +49,9 @@ (let loop ((c #\space)) (case c [(#\n #\N) (throw 'return)] - [(#\y #\Y) (map (lambda (e) (calendar-import calendar e)) + [(#\y #\Y) (map (lambda (e) + (add-event calendar e) + (save-event e)) (children new-events))] [else (let ((line (read-line))) diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 4810dc0c..aaff398e 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -141,7 +141,7 @@ (parameterize ((warnings-are-errors #t)) (catch 'warning - (lambda () (calendar-import calendar event)) + (lambda () (add-event calendar event)) (lambda (err fmt args) (return (build-response code: 400) (format #f "~?~%" fmt args))))) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 5616394c..0020b864 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -37,19 +37,10 @@ (children cal))) (getf 'calendars)))) - (setf 'fixed-and-repeating-events - (let* ((repeating regular (partition repeating? (getf 'events)))) + (let* ((repeating regular (partition repeating? (getf 'events)))) + (setf 'fixed-events (sort*! regular date/-time<? (extract 'DTSTART))) + (setf 'repeating-events (sort*! repeating date/-time<? (extract 'DTSTART)))) - ;; (report-time! "Sorting") - ;; NOTE There might be instances where we don't care if the - ;; collection if sorted, but for the time beieng it's much - ;; easier to always sort it. - (list - (sort*! regular date/-time<? (extract 'DTSTART)) - (sort*! repeating date/-time<? (extract 'DTSTART))))) - - (setf 'fixed-events (car (getf 'fixed-and-repeating-events))) - (setf 'repeating-events (cadr (getf 'fixed-and-repeating-events))) (setf 'event-set (interleave-streams @@ -85,9 +76,43 @@ read-line)) +(define-public (add-event calendar event) + + (add-child! calendar event) + + (getf 'uid-map) + + (unless (prop event 'UID) + (set! (prop event 'UID) (uuidgen))) + + (let ((events (getf 'events))) + (setf 'events (cons event events))) + + (if (repeating? event) + (let ((repeating (getf 'repeating-events))) + (setf 'repeating-events (insert-ordered repeating ev-time<?))) + (let ((regular (getf 'fixed-events))) + (setf 'fixed-events (insert-ordered event regular ev-time<?)))) + + (let ((event-set (getf 'event-set))) + (setf 'event-set + (interleave-streams + ev-time<? + (list (if (repeating? event) + (generate-recurrence-set event) + (stream event)) + event-set)))) + + (hash-set! (getf 'uid-map) (prop event 'UID) + event) + + (prop event 'UID)) + + (define / file-name-separator-string) -(define-public (calendar-import calendar event) +(define-public (save-event event) + (define calendar (parent event)) (case (prop calendar 'X-HNH-SOURCETYPE) [(file) (error "Importing into direct calendar files not supported")] |