From 27884c59318895bdaf9073944eb7e2037875ec0b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 4 Jul 2020 01:58:52 +0200
Subject: Add live import of event.

---
 module/entry-points/import.scm |  4 +++-
 module/entry-points/server.scm |  2 +-
 module/vcomponent.scm          | 51 +++++++++++++++++++++++++++++++-----------
 3 files changed, 42 insertions(+), 15 deletions(-)

(limited to 'module')

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")]
-- 
cgit v1.2.3