Move remaining stuff out of vcomponent.

2 files changed, 90 insertions, 33 deletions

diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm
index 29537a5e..71852adf 100644
--- a/module/vcomponent/parse.scm
+++ b/module/vcomponent/parse.scm
@@ -3,6 +3,9 @@
   :use-module (rnrs bytevectors)
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-9)
+  :use-module (srfi srfi-19)
+  :use-module (srfi srfi-19 setters)
+  :use-module (srfi srfi-19 util)
   :use-module ((ice-9 rdelim) :select (read-line))
   :use-module ((ice-9 textual-ports) :select (unget-char))
   :use-module ((ice-9 ftw) :select (scandir ftw))
@@ -10,6 +13,7 @@
   :use-module (util)
   :use-module (util strbuf)
   :use-module (vcomponent base)
+  :use-module (vcomponent datetime)
   )
 
 (use-modules ((rnrs base) #:select (assert)))
@@ -74,7 +78,7 @@
 
            'end-of-line])))
 
-(define (parse-calendar port)
+(define-public (parse-calendar port)
   (with-input-from-port port
     (lambda ()
       (let ((component (make-vcomponent))
@@ -203,6 +207,47 @@ row ~a	column ~a	ctx = ~a
 
 
 
+;; All VTIMEZONE's seem to be in "local" time in relation to
+;; themselves. Therefore, a simple comparison should work,
+;; and then the TZOFFSETTO attribute can be subtracted from
+;; the event DTSTART to get UTC time.
+
+(define (parse-dates! cal)
+  "Parse all start times into scheme date objects."
+
+  (for ev in (filter (lambda (o) (eq? 'VEVENT (type o))) (children cal))
+       (let-env ((TZ (and=> (prop (attr* ev 'DTSTART) 'TZID) car)))
+                (let*
+                    ((dptr (attr* ev 'DTSTART))
+                     (eptr (attr* ev 'DTEND))
+
+                     (date (parse-datetime (value dptr)))
+                     (end-date
+                      (cond ;; [(attr ev 'DURATION) => (lambda (d) (add-duration ...))]
+                       [(not eptr)
+                        (let ((d (set (date-hour date) = (+ 1))))
+                          (set! (attr ev 'DTEND) d
+                                eptr (attr* ev 'DTEND))
+                          d)]
+                       [(value eptr) => parse-datetime]
+                       [else
+                        (set (date-hour date) = (+ 1))])))
+
+                  (set! (value dptr) (date->time-utc date)
+                        (value eptr) (date->time-utc end-date))
+
+                  (when (prop (attr* ev 'DTSTART) 'TZID)
+                    ;; Re-align date to have correect timezone. This is since time->date gives
+                    ;; correct, but the code above may (?) fail to update the timezone.
+                    (set! (zone-offset date) (zone-offset (time-utc->date (value dptr)))
+                          (value dptr) (date->time-utc date)
+
+                          ;; The standard says that DTEND must have the same
+                          ;; timezone as DTSTART. Here we trust that blindly.
+                          (zone-offset end-date) (zone-offset date)
+                          (value eptr) (date->time-utc end-date)))))))
+
+
 (define (parse-vdir path)
   (let ((/ (lambda args (string-join args file-name-separator-string 'infix))))
     (let ((color
@@ -234,17 +279,29 @@ row ~a	column ~a	ctx = ~a
 
 (define-public (parse-cal-path path)
   (define st (stat path))
-  (case (stat:type st)
-    [(regular)
-     (let ((comp (call-with-input-file path parse-calendar)))
-       (set! (attr comp 'X-HNH-SOURCETYPE) "file")
-       comp) ]
-    [(directory)
-     (let ((comp (parse-vdir path)))
-       (set! (attr comp 'X-HNH-SOURCETYPE) "vdir")
-       comp)]
-    [(block-special char-special fifo socket unknown symlink)
-     => (lambda (t) (error "Can't parse file of type " t))]))
+  (define cal
+   (case (stat:type st)
+     [(regular)
+      (let ((comp (call-with-input-file path parse-calendar)))
+        (set! (attr comp 'X-HNH-SOURCETYPE) "file")
+        comp) ]
+     [(directory)
+      (let ((comp (parse-vdir path)))
+        (set! (attr comp 'X-HNH-SOURCETYPE) "vdir")
+        comp)]
+     [(block-special char-special fifo socket unknown symlink)
+      => (lambda (t) (error "Can't parse file of type " t))]))
+
+    (parse-dates! cal)
+
+    (unless (attr cal "NAME")
+      (set! (attr cal "NAME")
+        (or (attr cal "X-WR-CALNAME")
+            "[NAMELESS]")))
+
+    cal
+
+  )
 
 
 
diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm
index 6e022bcc..58961f5e 100644
--- a/module/vcomponent/recurrence/generate.scm
+++ b/module/vcomponent/recurrence/generate.scm
@@ -45,27 +45,27 @@
 
 (define (next-event ev r)
   (let ((e (copy-vcomponent ev)))
-    (let-env ((TZ (and=> (prop (attr* e 'DTSTART) 'TZID) car))))
-
-    (let ((d (time-utc->date (attr e 'DTSTART)))
-          (i (interval r)))
-      (case (freq r)
-        ((SECONDLY) (mod! (second d) = (+ i)))
-        ((MINUTELY) (mod! (minute d) = (+ i)))
-        ((HOURLY)   (mod! (hour   d) = (+ i)))
-        ((DAILY)    (mod! (day    d) = (+ i)))
-        ((WEEKLY)   (mod! (day    d) = (+ (* i 7))))
-        ((MONTHLY)  (mod! (month  d) = (+ i)))
-        ((YEARLY)   (mod! (year   d) = (+ i))))
-
-      (set! (zone-offset d)
-        (zone-offset (time-utc->date (date->time-utc d))))
-
-      (set! (attr e 'DTSTART) (date->time-utc d)))
-
-    (when (attr e 'DTEND)
-      (set! (attr e 'DTEND)
-        (add-duration (attr e 'DTSTART) (attr e 'DURATION))))
+    (let-env ((TZ (and=> (prop (attr* e 'DTSTART) 'TZID) car)))
+
+             (let ((d (time-utc->date (attr e 'DTSTART)))
+                   (i (interval r)))
+               (case (freq r)
+                 ((SECONDLY) (mod! (second d) = (+ i)))
+                 ((MINUTELY) (mod! (minute d) = (+ i)))
+                 ((HOURLY)   (mod! (hour   d) = (+ i)))
+                 ((DAILY)    (mod! (day    d) = (+ i)))
+                 ((WEEKLY)   (mod! (day    d) = (+ (* i 7))))
+                 ((MONTHLY)  (mod! (month  d) = (+ i)))
+                 ((YEARLY)   (mod! (year   d) = (+ i))))
+
+               (set! (zone-offset d)
+                 (zone-offset (time-utc->date (date->time-utc d))))
+
+               (set! (attr e 'DTSTART) (date->time-utc d)))
+
+             (when (attr e 'DTEND)
+               (set! (attr e 'DTEND)
+                 (add-duration (attr e 'DTSTART) (attr e 'DURATION)))))
 
     e))