From 8e93d53e6665e6ad782f94911032f043f9377ca4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 6 Dec 2021 03:55:47 +0100
Subject: Update xcal rrule parser to do as expected.

---
 module/vcomponent/xcal/parse.scm | 96 ++++++++++++++++++++++++++--------------
 1 file changed, 62 insertions(+), 34 deletions(-)

(limited to 'module')

diff --git a/module/vcomponent/xcal/parse.scm b/module/vcomponent/xcal/parse.scm
index 48ce301e..c6a2122f 100644
--- a/module/vcomponent/xcal/parse.scm
+++ b/module/vcomponent/xcal/parse.scm
@@ -49,40 +49,68 @@
              ((@ (vcomponent duration) parse-duration) duration))])]
 
     [(recur)
-     (apply (@ (vcomponent recurrence internal) make-recur-rule)
-            (concatenate
-             (for (k v) in value
-                  (list (symbol->keyword k)
-                        (case k
-                          ((wkst)
-                           ((@ (vcomponent recurrence parse)
-                               rfc->datetime-weekday)
-                            (string->symbol v)))
-                          ((freq) (string->symbol v))
-                          ((until)
-                           ;; RFC 6321 (xcal), p. 30 specifies type-until as
-                           ;;     type-until = element until {
-                           ;;         type-date |
-                           ;;         type-date-time
-                           ;;     }
-                           ;; but doesn't bother defining type-date[-time]...
-                           ;; This is acknowledged in errata 3315 [1], but
-                           ;; it lacks a solution...
-                           ;; Seeing as RFC 7265 (jcal) in Example 2 (p. 16)
-                           ;; show the date as a direct string we will roll
-                           ;; with that here to.
-                           ;; [1]: https://www.rfc-editor.org/errata/eid3315
-                           (string->date/-time v))
-                        ((byday) #|TODO|#
-                         (throw 'not-yet-implemented))
-                        ((count interval bysecond bymunite byhour
-                                bymonthday byyearday byweekno
-                                bymonth bysetpos)
-                         (string->number v))
-                        (else (throw
-                               'key-error
-                               "Invalid key ~a, with value ~a"
-                               k v)))))))]
+     ;; RFC6221 (xcal) Appendix A 3.3.10 specifies that all components should
+     ;; come in a specified order, and by extension that all components of the
+     ;; same type should follow each other. Actually checking that is harder
+     ;; than to just accept anything in any order. It would also make us less
+     ;; robust for other implementations with other ideas.
+     (let ((parse-value-of-that-type
+            (lambda (type value)
+              (case type
+                ((wkst)
+                 ((@ (vcomponent recurrence parse)
+                     rfc->datetime-weekday)
+                  (string->symbol value)))
+                ((freq) (string->symbol value))
+                ((until)
+                 ;; RFC 6321 (xcal), p. 30 specifies type-until as
+                 ;;     type-until = element until {
+                 ;;         type-date |
+                 ;;         type-date-time
+                 ;;     }
+                 ;; but doesn't bother defining type-date[-time]...
+                 ;; This is acknowledged in errata 3315 [1], but
+                 ;; it lacks a solution...
+                 ;; Seeing as RFC 7265 (jcal) in Example 2 (p. 16)
+                 ;; show the date as a direct string we will roll
+                 ;; with that here to.
+                 ;; [1]: https://www.rfc-editor.org/errata/eid3315
+                 (string->date/-time value))
+                ((byday) ((@@ (vcomponent recurrence parse) parse-day-spec) value))
+                ((count interval bysecond bymunite byhour
+                        bymonthday byyearday byweekno
+                        bymonth bysetpos)
+                 (string->number value))
+                (else (throw
+                       'key-error
+                       "Invalid type ~a, with value ~a"
+                       type value))))))
+
+       ;; freq until count interval wkst
+
+       (apply (@ (vcomponent recurrence internal) make-recur-rule)
+              (concatenate
+               (filter identity
+                       (for key in '(bysecond byminute byhour byday bymonthday
+                                              byyearday byweekno bymonth bysetpos
+                                              freq until count interval wkst)
+                        (define values (assoc-ref-all value key))
+                        (if (null? values)
+                            #f
+                            (case key
+                              ;; These fields all have zero or one value
+                              ((freq until count interval wkst)
+                               (list (symbol->keyword key)
+                                     (parse-value-of-that-type
+                                      key (car (map car values)))))
+                              ;; these fields take lists
+                              ((bysecond byminute byhour byday bymonthday
+                                         byyearday byweekno bymonth bysetpos)
+                               (list (symbol->keyword key)
+                                     (map (lambda (v) (parse-value-of-that-type key v))
+                                          (map car values)))
+                               )
+                              (else (throw 'error)))))))))]
 
     [(time) (parse-iso-time (car value))]
 
-- 
cgit v1.2.3