;; GNU Shepherd --- Test timer service.
;; Copyright © 2024-2025 Ludovic Courtès <ludo@gnu.org>
;;
;; This file is part of the GNU Shepherd.
;;
;; The GNU Shepherd is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or (at
;; your option) any later version.
;;
;; The GNU Shepherd is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with the GNU Shepherd.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-timer)
  #:use-module ((shepherd service) #:select (default-environment-variables))
  #:use-module (shepherd service timer)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-64))

;; This is the timezone corresponding to 'Europe/Paris'.  This TZ string works
;; even in the absence of tzdata.
;;
;; As per "(libc) TZ Variable", it means that summer time (CEST) begins on
;; March’s last Sunday at 2:00am, and ends on October’s last Sunday at 3:00am.
(setenv "TZ" "CET-1CEST,M3.5.0,M10.5.0/3")

(test-begin "timer")

(test-assert "calendar-event, out of range"
  (guard (c ((message-condition? c) #t))
    (calendar-event #:months '(0 1 2))
    #f))

(test-equal "next-calendar-event, leap year"
  (make-date 0 0 00 12 29 02 2024 3600)
  (next-calendar-event (calendar-event #:hours '(12) #:minutes '(0))
                       (make-date 123456789 42 44 12 28 02 2024 3600)))

(test-equal "next-calendar-event, non-leap year"
  (make-date 0 0 00 12 01 03 2023 3600)
  (next-calendar-event (calendar-event #:hours '(12) #:minutes '(0))
                       (make-date 123456789 42 44 12 28 02 2023 3600)))

(test-equal "next-calendar-event, same day"
  (make-date 0 0 42 12 28 02 2024 3600)
  (next-calendar-event (calendar-event #:hours '(12) #:minutes '(42))
                       (make-date 123456789 42 09 12 28 02 2024 3600)))

(test-equal "next-calendar-event, days of week"
  `(,(make-date 0 0 30 12 02 03 2024 3600)
    ,(make-date 0 0 30 18 02 03 2024 3600)
    ,@(append-map (lambda (day)
                    (list (make-date 0 0 30 06 day 03 2024 3600)
                          (make-date 0 0 30 12 day 03 2024 3600)
                          (make-date 0 0 30 18 day 03 2024 3600)))
                  '(03 06 09)))
  ;;      March 2024
  ;; Su Mo Tu We Th Fr Sa
  ;;                 1  2
  ;;  3  4  5  6  7  8  9
  ;; 10 11 12 13 14 15 16
  ;; 17 18 19 20 21 22 23
  ;; 24 25 26 27 28 29 30
  ;; 31
  (let ((event (calendar-event #:hours '(6 12 18)
                               #:minutes '(30)
                               #:days-of-week '(sunday wednesday saturday))))
    (let loop ((date (make-date 123456789 42 09 12
                                ;; Start on Saturday, March 2nd.
                                02 03 2024 3600))
               (n 0)
               (result '()))
      (if (< n 11)
          (let ((date (next-calendar-event event date)))
            (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 05 2024 7200)) ;CEST = UTC+2
               (iota 31 1))
          (map (lambda (day)
                 (make-date 0 0 14 17 day 06 2024 7200))
               (iota 14 1)))
  (let ((event (calendar-event #:hours '(17)
                               #:minutes '(14))))
    (let loop ((date (make-date 123456789 42 09 12
                                01 05 2024 7200))
               (n 0)
               (result '()))
      (if (< n (+ 31 14))
          (let ((date (next-calendar-event event date)))
            (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 7200)     ;CEST = UTC+2
        (make-date 0 0 14 17 01 09 2024 7200)
        (make-date 0 0 14 17 06 10 2024 7200)
        (make-date 0 0 14 17 03 11 2024 3600)     ;CET = UTC+1
        (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
                                1234))         ;actual tz offset is recomputed
               (n 0)
               (result '()))
      (if (< n 7)
          (let ((date (next-calendar-event event date)))
            (loop date (+ 1 n) (cons date result)))
          (reverse result)))))

(test-equal "next-calendar-event, every Friday 13th"
  (list (make-date 0 0 14 17 13 09 2024 7200)     ;CEST
        (make-date 0 0 14 17 13 12 2024 3600)     ;CET
        (make-date 0 0 14 17 13 06 2025 7200)     ;CEST
        (make-date 0 0 14 17 13 02 2026 3600)     ;CET
        (make-date 0 0 14 17 13 03 2026 3600))
  (let ((event (calendar-event #:hours '(17)
                               #:minutes '(14)
                               #:days-of-week '(friday)
                               #:days-of-month '(13))))
    (let loop ((date (make-date 123456789 42 09 12
                                01 08 2024 3600))
               (n 0)
               (result '()))
      (if (< n 5)
          (let ((date (next-calendar-event event date)))
            (loop date (+ 1 n) (cons date result)))
          (reverse result)))))

;; DST changes occur on March's last Sunday (30 March 2025) and on October's
;; last Sunday (26 October 2025).
(test-equal "next-calendar-event, across DST"
  (list (make-date 0 0 00 12 30 03 2025 7200)     ;CEST
        (make-date 0 0 00 12 26 10 2025 3600))    ;CET
  (let ((event (calendar-event #:hours '(12)
                               #:minutes '(0))))
    (list (next-calendar-event event
                               (make-date 0 0 55 22 29 03 2025 3600))
          (next-calendar-event event
                               (make-date 0 0 55 22 25 10 2025 7200)))))

(test-equal "next-calendar-event, CEST -> CET, repeated hour"
  ;; Change from CEST to CET happens at 3:00am, so 03:30am happens twice, once
  ;; with each timezone.  Yet 'next-calendar-event' only picks one occurrence.
  (list (make-date 0 0 30 03 25 10 2025 7200)     ;CEST
        (make-date 0 0 30 03 26 10 2025 3600)     ;CET
        (make-date 0 0 30 03 27 10 2025 3600)
        (make-date 0 0 30 03 28 10 2025 3600)
        (make-date 0 0 30 03 29 10 2025 3600))
  (let ((event (calendar-event #:hours '(03)
                               #:minutes '(30))))
    (let loop ((date (make-date 0 0 30 14 24 10 2025 7200))
               (n 0)
               (result '()))
      (if (< n 5)
          (let ((date (next-calendar-event event date)))
            (loop date (+ 1 n) (cons date result)))
          (reverse result)))))

(test-equal "next-calendar-event, CET -> CEST, nonexistent hour"
  ;; Change from CET to CEST happens at 2:00am, so 02:30am never happens on
  ;; that day.  Yet 'next-calendar-event' pretends it exists in CEST.
  (list (make-date 0 0 30 02 29 03 2025 3600)     ;CET
        (make-date 0 0 30 02 30 03 2025 7200)     ;CEST
        (make-date 0 0 30 02 31 03 2025 7200)
        (make-date 0 0 30 02 01 04 2025 7200)
        (make-date 0 0 30 02 02 04 2025 7200))
  (let ((event (calendar-event #:hours '(02)
                               #:minutes '(30))))
    (let loop ((date (make-date 0 0 30 14 28 03 2025 3600))
               (n 0)
               (result '()))
      (if (< n 5)
          (let ((date (next-calendar-event event date)))
            (loop date (+ 1 n) (cons date result)))
          (reverse result)))))

(test-equal "seconds-to-wait, 12h between consecutive events"
  (make-list 200 (* 12 3600))
  (let ((event (calendar-event #:hours '(12 00)
                               #:minutes '(42))))
    (let loop ((time (date->time-utc
                      (make-date 0 0 42 12 01 04 2025 7200))) ;CEST
               (n 0)
               (result '()))
      (if (< n 200)
          (let ((seconds (inexact->exact (seconds-to-wait event time))))
            (loop (make-time time-utc 0 (+ seconds (time-second time)))
                  (+ 1 n)
                  (cons seconds result)))
          (reverse result)))))

(test-equal "seconds-to-wait, CEST -> CET, daily"
  (list (* 24 3600)                               ;October 24th to 25th
        (* 25 3600)                               ;25th to 26th
        (* 24 3600)
        (* 24 3600)
        (* 24 3600))
  (let ((event (calendar-event #:hours '(12)
                               #:minutes '(30))))
    (let loop ((time (date->time-utc
                      (make-date 0 0 30 12 24 10 2025 7200))) ;CEST
               (n 0)
               (result '()))
      (if (< n 5)
          (let ((seconds (inexact->exact (seconds-to-wait event time))))
            (loop (make-time time-utc 0 (+ seconds (time-second time)))
                  (+ 1 n)
                  (cons seconds result)))
          (reverse result)))))

(test-equal "seconds-to-wait, CET -> CEST, daily"
  (list (* 24 3600)                               ;March 28th to 29th
        (* 23 3600)                               ;29th to 30th
        (* 24 3600)
        (* 24 3600)
        (* 24 3600))
  (let ((event (calendar-event #:hours '(12)
                               #:minutes '(30))))
    (let loop ((time (date->time-utc
                      (make-date 0 0 30 12 28 03 2025 3600))) ;CET
               (n 0)
               (result '()))
      (if (< n 5)
          (let ((seconds (inexact->exact (seconds-to-wait event time))))
            (loop (make-time time-utc 0 (+ seconds (time-second time)))
                  (+ 1 n)
                  (cons seconds result)))
          (reverse result)))))

(test-equal "seconds-to-wait, CEST -> CET, hourly"
  (append (make-list 3 3600)
          '(7200)                     ;Oct. 26th, from 02:30 CEST to 03:30 CET
          (make-list 20 3600))
  (let ((event (calendar-event #:minutes '(30))))
    (let loop ((time (date->time-utc
                      (make-date 0 0 30 23 25 10 2025 7200))) ;CEST
               (n 0)
               (result '()))
      (if (< n 24)
          (let ((seconds (inexact->exact (seconds-to-wait event time))))
            (loop (make-time time-utc 0 (+ seconds (time-second time)))
                  (+ 1 n)
                  (cons seconds result)))
          (reverse result)))))

(test-equal "seconds-to-wait, CEST -> CET, every 15mn"
  (append (make-list 11 (* 15 60))    ;Oct. 26th, from 00:00 CEST to 02:45 CEST
          (list (+ 3600 (* 15 60)))   ;Oct. 26th, from 02:45 CEST to 03:00 CET
          (make-list 4 (* 15 60)))
  (let ((event (calendar-event #:minutes '(0 15 30 45))))
    (let loop ((time (date->time-utc
                      (make-date 0 0 00 00 26 10 2025 7200))) ;CEST
               (n 0)
               (result '()))
      (if (< n 16)
          (let ((seconds (inexact->exact (seconds-to-wait event time))))
            (pk (time-utc->date time))
            (loop (make-time time-utc 0 (+ seconds (time-second time)))
                  (+ 1 n)
                  (cons seconds result)))
          (reverse result)))))

(test-equal "seconds-to-wait, CET -> CEST, hourly"
  (make-list 24 3600)
  (let ((event (calendar-event #:minutes '(30))))
    (let loop ((time (date->time-utc
                      (make-date 0 0 30 23 29 03 2025 3600))) ;CET
               (n 0)
               (result '()))
      (if (< n 24)
          (let ((seconds (inexact->exact (seconds-to-wait event time))))
            (loop (make-time time-utc 0 (+ seconds (time-second time)))
                  (+ 1 n)
                  (cons seconds result)))
          (reverse result)))))

(test-equal "seconds-to-wait, CET -> CEST, every 15mn"
  (make-list 16 900)
  (let ((event (calendar-event #:minutes '(0 15 30 45))))
    (let loop ((time (date->time-utc
                      (make-date 0 0 00 00 30 03 2025 3600))) ;CET
               (n 0)
               (result '()))
      (if (< n 16)
          (let ((seconds (inexact->exact (seconds-to-wait event time))))
            (loop (make-time time-utc 0 (+ seconds (time-second time)))
                  (+ 1 n)
                  (cons seconds result)))
          (reverse result)))))

(let-syntax ((test-cron (syntax-rules ()
                          ((_ str calendar)
                           (test-equal (string-append
                                        "cron-string->calendar-event, "
                                        (object->string str))
                             calendar
                             (cron-string->calendar-event str))))))

  ;; Every minute.
  (test-cron "* * * * *" (calendar-event))

  ;; Every hour.
  (test-cron "42 * * * *" (calendar-event #:minutes '(42)))

  ;; Every other hour.
  (test-cron "0 */2 * * *"
             (calendar-event #:minutes '(0)
                             #:hours (iota 12 0 2)))

  ;; Every three hours.
  (test-cron "0 */3 * * *"
             (calendar-event #:minutes '(0)
                             #:hours (iota (floor-quotient 24 3) 0 3)))

  ;; At 0am and 11pm (example from
  ;; <https://www.man7.org/linux/man-pages/man5/crontab.5.html>).
  (test-cron "0 */23 * * *"
             (calendar-event #:minutes '(0)
                             #:hours '(0 23)))

  ;; Every 15 minutes.
  (test-cron "*/15 * * * *"
             (calendar-event #:minutes '(0 15 30 45)))

  ;; The following examples come from the mcron manual (info "(mcron) Crontab
  ;; file"); some of them were borrowed from
  ;; <https://www.man7.org/linux/man-pages/man5/crontab.5.html>.

  ;; 4:30 am on the 1st and 15th of each month, plus every Friday
  (test-cron "30 4 1,15 * 5"
             (calendar-event #:minutes '(30)
                             #:hours '(4)
                             #:days-of-month '(1 15)
                             #:days-of-week '(friday)))

  ;; five minutes after midnight, every day
  (test-cron "5 0 * * *"
             (calendar-event #:minutes '(5)
                             #:hours '(0)))
  ;; 2:15pm on the first of every month
  (test-cron "15 14 1 * *"
             (calendar-event #:minutes '(15)
                             #:hours '(14)
                             #:days-of-month '(1)))
  ;; 10 pm on weekdays
  (test-cron "0 22 * * 1-5"
             (calendar-event #:minutes '(0)
                             #:hours '(22)
                             #:days-of-week '(monday
                                              tuesday
                                              wednesday
                                              thursday
                                              friday)))

  ;; 23 minutes after midnight, 2am, 4am ..., everyday
  (test-cron "23 0-23/2 * * *"
             (calendar-event #:minutes '(23)
                             #:hours (iota 12 0 2)))

  ;; at 5 after 4 every Sunday
  (test-cron "5 4 * * 0"
             (calendar-event #:minutes '(5)
                             #:hours '(4)
                             #:days-of-week '(sunday))))

(let-syntax ((test-cron-error
              (syntax-rules ()
                ((_ str invalid-field)
                 (test-equal (format #f "cron-string->calendar-event, \
invalid ~a field"
                                     invalid-field)
                   (format #f "~s: invalid ~a cron field"
                           str invalid-field)
                   (guard (c ((message-condition? c)
                              (condition-message c)))
                     (cron-string->calendar-event str)))))))

  (test-cron-error "30 4 1,55 * 0" 'days-of-month)
  (test-cron-error "30 4 22 * 9" 'days-of-week)
  (test-cron-error "0-99 4 22 * *" 'minutes))

(test-equal "timer-arguments->calendar-event, simple"
  (list (calendar-event #:seconds '(0)
                        #:minutes '(14)
                        #:hours '(17))
        '("echo" "hello"))
  (call-with-values
      (lambda ()
        (timer-arguments->calendar-event+command
         '("at" "17:14" "echo" "hello")))
    list))

(test-assert "timer-arguments->calendar-event, wrong-type-arg"
  (catch 'wrong-type-arg
    (lambda ()
      (timer-arguments->calendar-event+command '("echo" "forgot something"))
      #f)
    (const #t)))

(test-end "timer")
