Event edit within calendar now works.

2 files changed, 58 insertions, 20 deletions

diff --git a/module/server/routes.scm b/module/server/routes.scm
index 1e3af921..bf5165a9 100644
--- a/module/server/routes.scm
+++ b/module/server/routes.scm
@@ -158,9 +158,6 @@
                       (format #f "No event with UID '~a'" uid))))
 
    ;; TODO this fails when dtstart is <date>.
-   ;; TODO If data has an explicit UID and that UID already exists we
-   ;; overwrite it in the database. We however don't remove the old
-   ;; event from the in-memory set, but rather just adds the new.
    (POST "/insert" (cal data)
 
          (unless (and cal data)
@@ -170,7 +167,7 @@
 
          ;; NOTE that this leaks which calendar exists,
          ;; but you can only query for existance.
-         ;; also, the default output gives everything.
+         ;; also, the calendar view already show all calendars.
          (let ((calendar
                 (find (lambda (c) (string=? cal (prop c 'NAME)))
                       (get-calendars global-event-object))))
@@ -215,21 +212,54 @@
              ;; to use a /update endpoint to change events. This to prevent
              ;; accidental overwriting.
 
-             (parameterize ((warnings-are-errors #t))
-               (catch 'warning
-                 (lambda () (add-event global-event-object calendar event))
-                 (lambda (err fmt args)
-                   (return (build-response code: 400)
-                           (format #f "~?~%" fmt args)))))
-
-             ;; NOTE Posibly defer save to a later point.
-             ;; That would allow better asyncronous preformance.
-             (unless ((@ (output vdir) save-event) event)
-               (return (build-response code: 500)
-                       "Saving event to disk failed."))
-
-             (format (current-error-port)
-                     "Event inserted ~a~%" (prop event 'UID))
+
+             (cond
+              [(get-event-by-uid global-event-object (prop event 'UID))
+               => (lambda (old-event)
+
+                    (if (eq? calendar (parent old-event))
+                        (begin (vcomponent-update! old-event event)
+                               ;; for save below
+                               (set! event old-event))
+                        ;; change calendar
+                        (begin
+                          ;; (remove-from-calendar! old-event)
+                          (remove-event global-event-object old-event)
+
+                          (parameterize ((warnings-are-errors #t))
+                            (catch 'warning
+                              (lambda () (add-event global-event-object calendar event))
+                              (lambda (err fmt args)
+                                (return (build-response code: 400)
+                                        (format #f "~?~%" fmt args)))))))
+
+
+                    ;; NOTE Posibly defer save to a later point.
+                    ;; That would allow better asyncronous preformance.
+                    (unless ((@ (output vdir) save-event) event)
+                      (return (build-response code: 500)
+                              "Saving event to disk failed."))
+
+
+                    (format (current-error-port)
+                            "Event updated ~a~%" (prop event 'UID)))]
+
+              [else
+               (parameterize ((warnings-are-errors #t))
+                 (catch 'warning
+                   (lambda () (add-event global-event-object calendar event))
+                   (lambda (err fmt args)
+                     (return (build-response code: 400)
+                             (format #f "~?~%" fmt args)))))
+
+               ;; NOTE Posibly defer save to a later point.
+               ;; That would allow better asyncronous preformance.
+               (unless ((@ (output vdir) save-event) event)
+                 (return (build-response code: 500)
+                         "Saving event to disk failed."))
+
+               (format (current-error-port)
+                       "Event inserted ~a~%" (prop event 'UID))])
 
              (return '((content-type application/xml))
                      (with-output-to-string
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm
index 3e75e566..7b81fb05 100644
--- a/module/vcomponent/base.scm
+++ b/module/vcomponent/base.scm
@@ -148,7 +148,7 @@
   (hash-map->list cons (get-component-properties component)))
 
 (define-public (property-keys component)
-  (map car (get-component-properties component)))
+  (hash-map->list (lambda (a _) a) (get-component-properties component)))
 
 (define (copy-vline vline)
   (make-vline (vline-key vline)
@@ -169,6 +169,14 @@
                                     (copy-vline value))))
                     (get-component-properties component)))))
 
+;; updates target with all fields from source.
+;; fields in target but not in source left unchanged.
+;; parent and children unchanged
+(define-public (vcomponent-update! target source)
+  (for key in (property-keys source)
+       (set! (prop* target key)
+         (prop* source key))))
+
 (define-public (extract field)
   (lambda (e) (prop e field)))