;; GNU Shepherd --- Test timer service.
;; Copyright © 2024 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))

(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 03 2024 3600))
               (iota 31 1))
          (map (lambda (day)
                 (make-date 0 0 14 17 day 04 2024 3600))
               (iota 14 1)))
  (let ((event (calendar-event #:hours '(17)
                               #:minutes '(14))))
    (let loop ((date (make-date 123456789 42 09 12
                                01 03 2024 3600))
               (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 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)))))

(test-equal "next-calendar-event, every Friday 13th"
  (list (make-date 0 0 14 17 13 09 2024 3600)
        (make-date 0 0 14 17 13 12 2024 3600)
        (make-date 0 0 14 17 13 06 2025 3600)
        (make-date 0 0 14 17 13 02 2026 3600)
        (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)))))

(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))))))

  ;; The following examples come from the mcron manual (info "(mcron) Crontab
  ;; file").

  ;; 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))
        (command '("echo" "hello")))
  (call-with-values
      (lambda ()
        (timer-arguments->calendar-event+command
         '("at" "17:14" "echo" "hello")))
    list))

(test-equal "timer-arguments->calendar-event, \"as\""
  (list (calendar-event #:seconds '(56)
                        #:minutes '(34)
                        #:hours '(12))
        (let ((me (getpwuid (getuid))))
          (command '("echo" "hello")
                   #:user (passwd:name me)
                   #:group (group:name (getgrgid (passwd:gid me)))
                   #:directory (passwd:dir me)
                   #:environment-variables
                   (cons (string-append "HOME=" (passwd:dir me))
                         (default-environment-variables)))))
  (call-with-values
      (lambda ()
        (timer-arguments->calendar-event+command
         `("at" "12:34:56" "as" ,(passwd:name (getpwuid (getuid)))
           "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")
