[shepherd] 03/04: timer: Fix miscalculation of matching weekdays across several months.

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit 3fdceacd9a68a0465db3a4b41f4ebf052841efc1
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed May 22 09:24:04 2024 +0200

    timer: Fix miscalculation of matching weekdays across several months.
    
    Previously the intersection of weekdays and days of month would be
    computed for the current month and reused as-is even when looking for a
    date in the next month.  For example, in the “event Sunday” test, we’d
    pick June 5th as the next calendar even following May, simply because
    May 5th is on Sunday.
    
    * modules/shepherd/service/timer.scm (fit-day): Add ‘weekdays’ argument.
    Compute ‘days*’.  Recurse when switching to the next month.
    (next-calendar-event): Remove weekday/day-of-month intersection.  Update
    call to ‘fit-day’ and change ‘if’ condition.
    * tests/services/timer-events.scm ("next-calendar-event, every Sunday"):
    New test.
---
 modules/shepherd/service/timer.scm | 42 ++++++++++++++++++++++----------------
 tests/services/timer-events.scm    | 29 ++++++++++++++++++++++++++
 2 files changed, 53 insertions(+), 18 deletions(-)

diff --git a/modules/shepherd/service/timer.scm 
b/modules/shepherd/service/timer.scm
index 343dd77..4473676 100644
--- a/modules/shepherd/service/timer.scm
+++ b/modules/shepherd/service/timer.scm
@@ -234,8 +234,18 @@ is closer to @var{current} than its second argument.  The 
distance to
                            (increment-year date))))
              (set-date-month next first)))))))
 
-(define (fit-day date days)
-  (let loop ((candidates (sort days
+(define (fit-day date days weekdays)
+  (define days*
+    (if (eq? weekdays any-day-of-week)
+        days
+        (lset-intersection
+         =
+         days
+         (week-days->month-days weekdays
+                                (date-month date)
+                                (date-year date)))))
+
+  (let loop ((candidates (sort days*
                                (sooner (date-day date)
                                        (days-in-month (date-month date)
                                                       (date-year date))))))
@@ -244,10 +254,10 @@ is closer to @var{current} than its second argument.  The 
distance to
        (if (and (= first (date-day date))
                 (> (date-hour date) 0))
            (loop rest)
-           (let ((next (if (>= first (date-day date))
-                           date
-                           (increment-month date))))
-             (set-date-day next first)))))))
+           (if (>= first (date-day date))
+               (set-date-day date first)
+               (let ((date (increment-month (set-date-day date 1))))
+                 (fit-day date days weekdays))))))))
 
 (define (fit-hour date hours)
   (let loop ((candidates (sort hours
@@ -309,18 +319,14 @@ event record."
         (fit-month date (calendar-event-months event))))
 
   (define (day date)
-    (let ((days (if (eq? (calendar-event-days-of-week event)
-                         any-day-of-week)
-                    (calendar-event-days-of-month event)
-                    (lset-intersection
-                     =
-                     (calendar-event-days-of-month event)
-                     (week-days->month-days (calendar-event-days-of-week event)
-                                            (date-month date)
-                                            (date-year date))))))
-      (if (memv (date-day date) days)
-          date
-          (fit-day date days))))
+    (if (and (memv (date-day date)
+                   (calendar-event-days-of-month event))
+             (memv (date-week-day date)
+                   (calendar-event-days-of-week event)))
+        date
+        (fit-day date
+                 (calendar-event-days-of-month event)
+                 (calendar-event-days-of-week event))))
 
   (define (hour date)
     (if (memv (date-hour date) (calendar-event-hours event))
diff --git a/tests/services/timer-events.scm b/tests/services/timer-events.scm
index f74bf5c..12113a5 100644
--- a/tests/services/timer-events.scm
+++ b/tests/services/timer-events.scm
@@ -75,6 +75,35 @@
             (loop date (+ 1 n) (cons date result)))
           (reverse result)))))
 
+(test-equal "next-calendar-event, every Sunday"
+  (list (make-date 0 0 0 22 26 05 2024 7200)
+        (make-date 0 0 0 22 02 06 2024 7200)
+        (make-date 0 0 0 22 09 06 2024 7200)
+        (make-date 0 0 0 22 16 06 2024 7200)
+        (make-date 0 0 0 22 23 06 2024 7200)
+        (make-date 0 0 0 22 30 06 2024 7200)
+        (make-date 0 0 0 22 07 07 2024 7200)
+        (make-date 0 0 0 22 14 07 2024 7200))
+  ;;       May 2024              June 2024             July 2024
+  ;; Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa
+  ;;           1  2  3  4                     1      1  2  3  4  5  6
+  ;;  5  6  7  8  9 10 11   2  3  4  5  6  7  8   7  8  9 10 11 12 13
+  ;; 12 13 14 15 16 17 18   9 10 11 12 13 14 15  14 15 16 17 18 19 20
+  ;; 19 20 21 22 23 24 25  16 17 18 19 20 21 22  21 22 23 24 25 26 27
+  ;; 26 27 28 29 30 31     23 24 25 26 27 28 29  28 29 30 31
+  ;;                       30
+  (let ((event (calendar-event #:hours '(22)
+                               #:minutes '(0)
+                               #:days-of-week '(sunday))))
+    (let loop ((date (make-date 123456789 42 09 12
+                                25 05 2024 7200))
+               (n 0)
+               (result '()))
+      (if (< n 8)
+          (let ((date (next-calendar-event event date)))
+            (loop date (+ 1 n) (cons date result)))
+          (reverse result)))))
+
 (test-equal "next-calendar-event, once everyday"
   (append (map (lambda (day)
                  (make-date 0 0 14 17 day 03 2024 3600))