Move code for saving event away from routes.

This frees it, currently only for calling it from our import entry
point, but this will also allow us to much easier write tests for it
(which we need since adding recurring events doesn't work).

2 files changed, 85 insertions, 64 deletions

diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm
index 6b3a77f3..88f641fb 100644
--- a/module/calp/server/routes.scm
+++ b/module/calp/server/routes.scm
@@ -253,69 +253,22 @@
              ;; accidental overwriting.
 
 
-             (cond
-              [(get-event-by-uid global-event-object (prop event 'UID))
-               => (lambda (old-event)
-
-                    ;; remove old instance of event from runtime
-                    ((@ (vcomponent util instance methods) remove-event)
-                     global-event-object old-event)
-
-                    ;; Add new event to runtime,
-                    ;; MUST be done after since the two events SHOULD share UID.
-                    (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)))))
-
-                    (set! (prop event 'LAST-MODIFIED)
-                      (current-datetime))
-
-                    ;; 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) event)
-                      (return (build-response code: 500)
-                              "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))
-
-
-                    (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)))))
-
-               (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)
-                 (return (build-response code: 500)
-                         "Saving event to disk failed."))
-
-               (format (current-error-port)
-                       "Event inserted ~a~%" (prop event 'UID))])
+             (parameterize ((warnings-are-errors #t))
+               (catch*
+                (lambda () (add-and-save-event global-event-object
+                                          calendar event))
+                (warning
+                 (lambda (err fmt args)
+                   (define str (format #f "~?" fmt args))
+                   (format (current-error-port) "400 ~a~%" str)
+                   (return (build-response code: 400)
+                           str)))
+                (#t
+                 (lambda (err proc fmt args _)
+                   (define str (format #f "~a in ~a: ~?~%" err proc fmt args))
+                   (format (current-error-port) "500 ~a~%" str)
+                   (return (build-response code: 500)
+                           str)))))
 
              (return '((content-type application/xml))
                      (with-output-to-string
diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm
index 18ac9330..1edad44b 100644
--- a/module/vcomponent/util/instance/methods.scm
+++ b/module/vcomponent/util/instance/methods.scm
@@ -18,8 +18,14 @@
            get-event-by-uid
            fixed-events-in-range
 
+           get-calendar-by-name
+
            get-event-set get-calendars
            get-fixed-events get-repeating-events
+
+           add-and-save-event
+
+           add-calendars
            ))
 
 (define-public (load-calendars calendar-files)
@@ -50,6 +56,10 @@
   (hash-ref (slot-ref this 'uid-map) uid))
 
 
+(define-method (get-calendar-by-name (this <events>) string)
+  (find (lambda (c) (string=? string (prop c 'NAME)))
+        (get-calendars this)))
+
 
 (define-method (fixed-events-in-range (this <events>) start end)
   (filter-sorted (lambda (ev) ((in-date-range? start end)
@@ -64,8 +74,12 @@
   (for calendar in (slot-ref this 'calendar-files)
        (format (current-error-port) "  - ~a~%" calendar))
 
-  (slot-set! this 'calendars (load-calendars (slot-ref this 'calendar-files)))
+  (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)))
 
   (let* ((groups
           (group-by
@@ -147,3 +161,57 @@
   (hash-set! (slot-ref this 'uid-map) (prop event 'UID)
              #f))
 
+
+
+(define-method (add-and-save-event (this <events>) calendar event)
+  (cond
+   [(get-event-by-uid this (prop event 'UID))
+    => (lambda (old-event)
+
+         ;; remove old instance of event from runtime
+         (remove-event this 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 event 'LAST-MODIFIED)
+           (current-datetime))
+
+         ;; 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) 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))
+
+
+         (format (current-error-port)
+                 "Event updated ~a~%" (prop event 'UID)))]
+
+   [else
+    (add-event this calendar event)
+
+    (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."))
+
+    (format (current-error-port)
+            "Event inserted ~a~%" (prop event 'UID))]))