[shepherd] 02/03: timer: Assume first candidate is valid when recursing on the next month.

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit 71ef394a38f1d78eada901cb4c111c7b2be84ab5
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Aug 17 00:31:09 2024 +0200

    timer: Assume first candidate is valid when recursing on the next month.
    
    * modules/shepherd/service/timer.scm (fit-day): Add optional ‘future?’
    parameter.  Pass it as #t on recursive call.
    * tests/services/timer-events.scm ("next-calendar-event, every first Sunday 
of the month"):
    New test.
    
    Reported-by: Felix Lechner <felix.lechner@lease-up.com>
---
 modules/shepherd/service/timer.scm |  7 ++++---
 tests/services/timer-events.scm    | 21 +++++++++++++++++++++
 2 files changed, 25 insertions(+), 3 deletions(-)

diff --git a/modules/shepherd/service/timer.scm 
b/modules/shepherd/service/timer.scm
index 302db6d..eca252d 100644
--- a/modules/shepherd/service/timer.scm
+++ b/modules/shepherd/service/timer.scm
@@ -234,7 +234,7 @@ 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 weekdays)
+(define* (fit-day date days weekdays #:optional future?)
   (define days*
     (if (eq? weekdays any-day-of-week)
         days
@@ -251,13 +251,14 @@ is closer to @var{current} than its second argument.  The 
distance to
                                                       (date-year date))))))
     (match candidates
       ((first . rest)
-       (if (and (= first (date-day date))
+       (if (and (not future?)
+                (= first (date-day date))
                 (> (date-hour date) 0))
            (loop rest)
            (if (>= first (date-day date))
                (set-date-day date first)
                (let ((date (increment-month (set-date-day date 1))))
-                 (fit-day date days weekdays))))))))
+                 (fit-day date days weekdays #t))))))))
 
 (define (fit-hour date hours)
   (let loop ((candidates (sort hours
diff --git a/tests/services/timer-events.scm b/tests/services/timer-events.scm
index 12113a5..dfe774c 100644
--- a/tests/services/timer-events.scm
+++ b/tests/services/timer-events.scm
@@ -122,6 +122,27 @@
             (loop date (+ 1 n) (cons date result)))
           (reverse result)))))
 
+(test-equal "next-calendar-event, every first Sunday of the month"
+  (list (make-date 0 0 14 17 04 08 2024 3600)
+        (make-date 0 0 14 17 01 09 2024 3600)
+        (make-date 0 0 14 17 06 10 2024 3600)
+        (make-date 0 0 14 17 03 11 2024 3600)
+        (make-date 0 0 14 17 01 12 2024 3600)
+        (make-date 0 0 14 17 05 01 2025 3600)
+        (make-date 0 0 14 17 02 02 2025 3600))
+  (let ((event (calendar-event #:hours '(17)
+                               #:minutes '(14)
+                               #:days-of-week '(sunday)
+                               #:days-of-month '(1 2 3 4 5 6 7))))
+    (let loop ((date (make-date 123456789 42 09 12
+                                01 08 2024 3600))
+               (n 0)
+               (result '()))
+      (if (< n 7)
+          (let ((date (next-calendar-event event date)))
+            (loop date (+ 1 n) (cons date result)))
+          (reverse result)))))
+
 (let-syntax ((test-cron (syntax-rules ()
                           ((_ str calendar)
                            (test-equal (string-append