;; timer.scm -- Timer service.
;; Copyright (C) 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 (shepherd service timer)
  #:use-module (shepherd service)
  #:use-module (shepherd support)
  #:use-module (shepherd comm)
  #:use-module ((fibers) #:hide (sleep))
  #:use-module (fibers channels)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:export (calendar-event
            calendar-event?
            calendar-event-months
            calendar-event-days-of-month
            calendar-event-days-of-week
            calendar-event-hours
            calendar-event-minutes
            calendar-event-seconds
            sexp->calendar-event
            cron-string->calendar-event

            next-calendar-event
            seconds-to-wait

            command
            command?
            command-arguments
            command-user
            command-group
            command-directory
            command-resource-limits
            command-environment-variables
            sexp->command

            make-timer-constructor
            make-timer-destructor

            trigger-timer
            timer-trigger-action

            timer-arguments->calendar-event+command
            timer-service))

;;; Commentary:
;;;
;;; This module implements constructors and destructors for "timers"--services
;;; that invoke commands periodically.
;;;
;;; Code:

(define-record-type <calendar-event>
  (%calendar-event seconds minutes hours days-of-month months days-of-week)
  calendar-event?
  (seconds       calendar-event-seconds)
  (minutes       calendar-event-minutes)
  (hours         calendar-event-hours)
  (days-of-month calendar-event-days-of-month)
  (months        calendar-event-months)
  (days-of-week  calendar-event-days-of-week))

(define-syntax define-weekday-symbolic-mapping
  (syntax-rules ()
    "Define @var{symbol->index} as a procedure that maps symbolic weekday
names to indexes, and @var{index->symbol} that does the opposite."
    ((_ symbol->index index->symbol (names ...))
     (begin
       (define symbol->index
         (let ((mapping (let loop ((lst '(names ...))
                                   (index 0)
                                   (result vlist-null))
                          (match lst
                            (()
                             result)
                            ((head . tail)
                             (loop tail
                                   (+ 1 index)
                                   (vhash-consq head index result)))))))
           (lambda (symbol)
             "Given @var{symbol}, a weekday, return its index or #f."
             (match (vhash-assq symbol mapping)
               (#f #f)
               ((_ . index) index)))))

       (define index->symbol
         (let ((mapping (vector 'names ...)))
           (lambda (index)
             "Given @var{index}, return the corresponding weekday symbol or #f."
             (and (>= index 0) (< index (vector-length mapping))
                  (vector-ref mapping index)))))))))

(define-weekday-symbolic-mapping
  weekday-symbol->index weekday-index->symbol
  (sunday monday tuesday wednesday thursday friday saturday))

(define any-minute (iota 60))
(define any-hour (iota 24))
(define any-day-of-month (iota 31 1))
(define any-day-of-week (map weekday-index->symbol (iota 7)))
(define any-month (iota 12 1))

(define-syntax validate-range
  (syntax-rules (-)
    ((_ lst min - max)
     (for-each (lambda (value)
                 (unless (and (>= value min) (<= value max))
                   (raise (condition
                           (&message
                            ;; TRANSLATORS: 'calendar-event' is the name of a
                            ;; procedure and it must be kept unchanged.
                            (message (format #f (l10n "calendar-event: ~a: \
~a: value out of range (~a-~a)")
                                             'lst value min max)))))))
               lst))))

(define (validate-days-of-week days-of-week)
  (for-each (lambda (value)
              (unless (memq value any-day-of-week)
                (raise (condition
                        (&message
                         (message (format #f (l10n "calendar-event: ~a: \
invalid day of week")
                                          value)))))))
            days-of-week))

(define* (calendar-event #:key
                         (seconds '(0))
                         (minutes any-minute)
                         (hours any-hour)
                         (days-of-week any-day-of-week)
                         (days-of-month any-day-of-month)
                         (months any-month))
  "Return a calendar event that obeys the given constraints."
  (validate-range seconds       0 - 59)
  (validate-range minutes       0 - 59)
  (validate-range hours         0 - 23)
  (validate-range days-of-month 1 - 31)
  (validate-range months        1 - 12)
  (validate-days-of-week days-of-week)

  (%calendar-event seconds minutes hours days-of-month months
                   (map weekday-symbol->index days-of-week)))

(define-syntax-rule (define-date-setter name getter)
  (define (name date value)
    (set-field date (getter) value)))

(define-date-setter set-date-nanosecond date-nanosecond)
(define-date-setter set-date-second date-second)
(define-date-setter set-date-minute date-minute)
(define-date-setter set-date-hour date-hour)
(define-date-setter set-date-day date-day)
(define-date-setter set-date-month date-month)
(define-date-setter set-date-year date-year)
(define-date-setter set-date-zone-offset date-zone-offset)

(define (increment-year date)
  (set-date-year date (+ 1 (date-year date))))

(define (increment-month date)
  (if (< (date-month date) 12)
      (set-date-month date (+ (date-month date) 1))
      (set-date-month (increment-year date) 1)))

(define (increment-day date)
  (if (< (date-day date)
         (days-in-month (date-month date) (date-year date)))
      (set-date-day date (+ (date-day date) 1))
      (set-date-day (increment-month date) 1)))

(define (increment-hour date)
  (if (< (date-hour date) 23)
      (set-date-hour date (+ (date-hour date) 1))
      (set-date-hour (increment-day date) 0)))

(define (increment-minute date)
  (if (< (date-minute date) 59)
      (set-date-minute date (+ (date-minute date) 1))
      (set-date-minute (increment-hour date) 0)))

(define (increment-second date)
  (if (< (date-second date) 59)
      (set-date-second date (+ (date-second date) 1))
      (set-date-second (increment-minute date) 0)))

(define (days-in-month month year)
  "Return the number of days in @var{month} of @var{year}."
  (let* ((next-day (make-date 0 0 0 0
                              1 (modulo (+ 1 month) 12)
                              (if (= 12 month) (+ 1 year) year)
                              0))
         (time (date->time-utc next-day))
         (date (time-utc->date
                (make-time time-utc 0
                           (- (time-second time) 3600))
                0)))
    (date-day date)))

(define (sooner current max)
  "Return a two-argument procedure that returns true when its first argument
is closer to @var{current} than its second argument.  The distance to
@var{current} is computed modulo @var{max}."
  (define (distance value)
    (modulo (- value current) max))

  (lambda (value1 value2)
    (< (distance value1) (distance value2))))

(define (fit-month date months)
  (let loop ((candidates (sort months
                               (sooner (date-month date) 12))))
    (match candidates
      ((first . rest)
       (if (and (= first (date-month date))
                (> (date-day date) 1))
           (loop rest)
           (let ((next (if (>= first (date-month date))
                           date
                           (increment-year date))))
             (set-date-month next first)))))))

(define* (fit-day date days weekdays #:optional future?)
  (define days*
    (if (eq? weekdays any-day-of-week)
        days
        (lset-intersection
         =
         days
         (week-days->month-days weekdays
                                (date-month date)
                                (date-year date)))))

  (if (and (null? days*)
           (not (null? days)) (not (null? weekdays)))
      ;; DAYS* is empty because the DAYS/WEEKDAYS intersection is empty--e.g.,
      ;; no Friday 13th this month.  Try the next month.
      (let ((date (increment-month (set-date-day date 1))))
        (fit-day date days weekdays #t))
      (let loop ((candidates (sort days*
                                   (sooner (date-day date)
                                           (days-in-month (date-month date)
                                                          (date-year date))))))
        (match candidates
          ((first . rest)
           (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 #t)))))))))

(define (fit-hour date hours)
  (let loop ((candidates (sort hours
                               (sooner (date-hour date) 24))))
    (match candidates
      ((first . rest)
       (if (and (= first (date-hour date))
                (> (date-minute date) 0))
           (loop rest)
           (let ((next (if (>= first (date-hour date))
                           date
                           (increment-day date))))
             (set-date-hour next first)))))))

(define (fit-minute date minutes)
  (let loop ((candidates (sort minutes
                               (sooner (date-minute date) 60))))
    (match candidates
      ((first . rest)
       (if (and (= first (date-minute date))
                (> (date-second date) 0))
           (loop rest)
           (let ((next (if (>= first (date-minute date))
                           date
                           (increment-hour date))))
             (set-date-minute next first)))))))

(define (fit-second date seconds)
  (let loop ((candidates (sort seconds
                               (sooner (date-second date) 60))))
    (match candidates
      ((first . rest)
       (if (and (= first (date-second date))
                (> (date-nanosecond date) 0))
           (loop rest)
           (let ((next (if (>= first (date-second date))
                           date
                           (increment-minute date))))
             (set-date-second next first)))))))

(define (week-days->month-days week-days month year)
  "Given @var{week-days}, a list of week-days (between 0 and 6, where 0 is
Sunday), return the corresponding list of days in @var{month} of @var{year}."
  (let loop ((date (make-date 0 0 0 0 1 month year 0))
             (days '()))
    (if (= (date-month date) month)
        (loop (increment-day date)
              (if (memv (date-week-day date) week-days)
                  (cons (date-day date) days)
                  days))
        (reverse days))))

(define (adjust-date-timezone-offset date)
  "Reset the timezone offset of the given date such that it matches the
local timezone offset at that time, taking DST into account."
  ;; This trick relies on the fact that the second argument of
  ;; 'time-utc->date' defaults to the local timezone offset for the given
  ;; time.
  (let ((offset (date-zone-offset (time-utc->date (date->time-utc date)))))
    (set-date-zone-offset date offset)))

(define (next-calendar-event event date)
  "Return the date following @var{date} that matches @var{event}, a calendar
event record.  The returned date has its @code{zone-offset} field adjusted to
represent the local time on that date, taking DST into account."
  (define (month date)
    (if (memv (date-month date) (calendar-event-months event))
        date
        (fit-month date (calendar-event-months event))))

  (define (day date)
    (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))
        date
        (fit-hour date (calendar-event-hours event))))

  (define (minute date)
    (if (memv (date-minute date) (calendar-event-minutes event))
        date
        (fit-minute date (calendar-event-minutes event))))

  (define (second date)
    (if (memv (date-second date) (calendar-event-seconds event))
        date
        (fit-second date (calendar-event-seconds event))))

  (define (nanosecond date)
    ;; Clear nanoseconds and jump to the next second.
    (increment-second (set-date-nanosecond date 0)))

  (adjust-date-timezone-offset
   (month (day (hour (minute (second (nanosecond date))))))))

(define* (seconds-to-wait event #:optional (now (current-time time-utc)))
  "Return the number of seconds to wait from @var{now} until the next occurrence
of @var{event} (the result is an inexact number, always greater than zero)."
  (let* ((now* (time-utc->date now))
         (then (next-calendar-event event now*))
         (diff (time-difference (date->time-utc then) now))
         (result (+ (time-second diff)
                    (/ (time-nanosecond diff) 1e9))))
    ;; If RESULT is zero or negative, that's presumably because of the
    ;; timezone offset difference between THEN and NOW--e.g., when switching
    ;; from CET (= UTC+1) to CEST (= UTC+2).  Compensate.
    (if (<= result 0)
        (+ result (- (date-zone-offset then) (date-zone-offset now*)))
        result)))

(define (cron-string->calendar-event str)
  "Convert @var{str}, which contains a Vixie cron date line, into the
corresponding @code{calendar-event}.  Raise an error if @var{str} is invalid.

A valid cron date line consists of 5 space-separated fields: minute, hour, day
of month, month, and day of week.  Each field can be an integer, or a
comma-separate list of integers, or a range.  Ranges are represented by two
integers separated by a hyphen, optionally followed by slash and a number of
repetitions.  Here are examples:

@table @code
@item 30 4 1,15 * *
4:30AM on the 1st and 15th of each month;
@item 5 0 * * *
five minutes after midnight, every day;
@item 23 0-23/2 * * 1-5
23 minutes after the hour every two hour, on weekdays.
@end table"
  (define not-comma
    (char-set-complement (char-set #\,)))
  (define not-hyphen
    (char-set-complement (char-set #\-)))

  (define (parse-component component count min)
    (define (in-range? n)
      (and (integer? n)
           (>= n min) (< n (+ min count))))

    (define (range->numbers str)
      (let ((str step (match (string-index str #\/)
                        (#f (values str 1))
                        (index
                         (values (string-take str index)
                                 (string->number
                                  (string-drop str (+ 1 index))))))))
        (match (string-tokenize str not-hyphen)
          (((= string->number min) (= string->number max))
           (and (>= max min)
                (in-range? min) (in-range? max)
                (iota (floor-quotient (+ 1 (- max min)) step)
                      min step)))
          (("*")
           (iota (ceiling-quotient count step) min step))
          (((= string->number n))
           (and (in-range? n) (list n)))
          (_ #f))))

    (match component
      ("*" (if (= 7 count)                        ;days of week?
               *unspecified*
               (iota count min)))
      (str (match (string-tokenize str not-comma)
             (((= range->numbers numbers) ...)
              (and (every list? numbers)
                   (let ((numbers (concatenate numbers)))
                     (if (= 7 count)
                         (map weekday-index->symbol numbers)
                         numbers))))
             (_ #f)))))

  (define (fail component)
    (raise (condition
            (&message
             (message (format #f "~s: invalid ~a cron field"
                              str component))))))

  (match (string-tokenize str)
    ((minutes hours days-of-month months days-of-week)
     (letrec-syntax ((parse (syntax-rules ()
                              ((_ ((id count min) rest ...) args)
                               (let ((id (parse-component id count min)))
                                 (if id
                                     (parse (rest ...)
                                            (if (unspecified? id)
                                                args
                                                (cons* (symbol->keyword 'id) id
                                                       args)))
                                     (fail 'id))))
                              ((_ () args)
                               (apply calendar-event args)))))
       (parse ((minutes 60 0) (hours 24 0)
               (days-of-month 31 1) (months 12 1) (days-of-week 7 0))
              '())))
    (_
     (raise (condition
             (&message
              (message (format #f "~s: wrong number of cron date fields"
                               str))))))))


;;;
;;; Timer services.
;;;

;; Timer value returned by 'make-timer-constructor'.
(define-record-type <timer>
  (timer channel event action)
  timer?
  (channel timer-channel)                         ;channel
  (event   timer-event)                           ;<calendar-event>
  (action  timer-action))                         ;<command> | procedure

(define (print-timer timer port)
  "Print @var{timer} to @var{port}, omitting its @code{channel} field for
conciseness."
  (format port "#<timer ~s ~s ~a>"
          (timer-event timer) (timer-action timer)
          (number->string (object-address timer) 16)))

(set-record-type-printer! <timer> print-timer)

;; Command to be executed by a timer.
(define-record-type <command>
  (%command arguments user group supplementary-groups
            environment-variables directory
            resource-limits)
  command?
  (arguments command-arguments)
  (user      command-user)
  (group     command-group)
  (supplementary-groups command-supplementary-groups)
  (environment-variables command-environment-variables)
  (directory command-directory)
  (resource-limits command-resource-limits))

(define* (command arguments #:key user group
                  (supplementary-groups '())
                  (environment-variables (default-environment-variables))
                  (directory (default-service-directory))
                  (resource-limits '()))
  "Return a new command for @var{arguments}, a program name and argument
list, to be executed as @var{user} and @var{group}, with the given
@var{environment-variables}, in @var{directory}, and with the given
@var{resource-limits}."
  (%command arguments user group supplementary-groups
            environment-variables directory
            resource-limits))

(define (calendar-event->sexp event)
  `(calendar-event (version 0)
                   (seconds ,(calendar-event-seconds event))
                   (minutes ,(calendar-event-minutes event))
                   (hours ,(calendar-event-hours event))
                   (days-of-month ,(calendar-event-days-of-month event))
                   (days-of-week ,(calendar-event-days-of-week event))
                   (months ,(calendar-event-months event))))

(define (sexp->calendar-event sexp)
  "Return the calendar event deserialized from @var{sexp}.  Return #f if
@var{sexp} is not recognized as a valid calendar event sexp."
  (match sexp
    (`(calendar-event (version 0)
                      (seconds ,seconds)
                      (minutes ,minutes)
                      (hours ,hours)
                      (days-of-month ,days-of-month)
                      (days-of-week ,days-of-week)
                      (months ,months))
     (%calendar-event seconds minutes hours days-of-month months
                      days-of-week))
    (_ #f)))

(define (command->sexp command)
  `(command (version 0)
            (arguments ,(command-arguments command))
            (user ,(command-user command))
            (group ,(command-group command))
            (supplementary-groups ,(command-supplementary-groups command))
            (environment-variables ,(command-environment-variables command))
            (directory ,(command-directory command))
            (resource-limits ,(command-resource-limits command))))

(define (sexp->command sexp)
  "Deserialize @var{sexp} into a command and return it.  Return #f if
@var{sexp} was not recognized."
  (match sexp
    (('command ('version 0)
               ('arguments arguments)
               ('user user) ('group group)
               ('supplementary-groups supplementary-groups)
               ('environment-variables environment-variables)
               ('directory directory)
               ('resource-limits resource-limits)
               _ ...)
     (command arguments #:user user #:group group
              #:supplementary-groups supplementary-groups
              #:environment-variables environment-variables
              #:directory directory
              #:resource-limits resource-limits))
    (_ #f)))

(define-record-type-serializer (serialize-timer (timer <timer>))
  ;; Serialize TIMER to clients can inspect it.
  `(timer (version 0)
          (event ,(match (timer-event timer)
                    ((? calendar-event? event)
                     (calendar-event->sexp event))
                    (_ #f)))
          (action ,(match (timer-action timer)
                     ((? command? command) (command->sexp command))
                     (_ 'procedure)))
          (processes ,(timer-processes timer))
          (remaining-occurrences ,(timer-remaining-occurrences timer))
          (past-runs ,(ring-buffer->list (timer-past-runs timer)))))

(define (timer-request message)
  (lambda (timer)
    "Send @var{message} to @var{timer} and return its reply."
    (let ((reply (make-channel)))
      (put-message (timer-channel timer) `(,message ,reply))
      (get-message reply))))

(define timer-processes
  ;; Return the list of PID/start time pairs of the currently running
  ;; processes started by the given timer.
  (timer-request 'processes))

(define timer-past-runs
  ;; Return the list of past runs as a ring buffer.  Each run has the form
  ;; (STATUS END START).  When the timer's action is a command, STATUS is an
  ;; integer, its exit status; otherwise, STATUS is either 'success or
  ;; '(exception ...).  END and START are the completion and start times,
  ;; respectively, as integers (seconds since the Epoch).
  (timer-request 'past-runs))

(define timer-remaining-occurrences
  ;; Return the number of remaining occurrences for this timer, possibly
  ;; +inf.0 (infinity).
  (timer-request 'remaining-occurrences))

(define sleep (@ (fibers) sleep))

(define %past-run-log-size
  ;; Maximum number of entries the log of timer runs.
  50)

(define* (make-timer-constructor event action
                                 #:key
                                 (occurrences +inf.0)
                                 log-file
                                 max-duration
                                 (termination-signal SIGTERM)
                                 wait-for-termination?)
  "Return a procedure for use as the @code{start} method of a service.  The
procedure will perform @var{action} for @var{occurrences} iterations of
@code{event}, a calendar event as returned by @code{calendar-event}.
@var{action} may be either a command (returned by @code{command}) or a thunk;
in the latter case, the thunk must be suspendable or it could block the whole
shepherd process.

When @var{log-file} is true, log the output of @var{action} to that file
rather than in the global shepherd log.

When @var{wait-for-termination?} is true, wait until @var{action} has finished
before considering executing it again; otherwise, perform @var{action}
strictly on every occurrence of @var{event}, at the risk of having multiple
instances running concurrently.

When @var{max-duration} is true, it is the maximum duration in seconds that a
run may last, provided @var{action} is a command.  Past @var{max-duration}
seconds, the timer's process is forcefully terminated with signal
@var{termination-signal}."
  (define (stop-self)
    ;; When the last occurrence has completed, the only way to let the service
    ;; controller know that we're done is by asking it to stop the service.
    (spawn-fiber
     (lambda ()
       (let ((self (current-service)))
         (local-output (l10n "Finished last occurrence of timer '~a'.")
                       (service-canonical-name self))
         (stop-service self)))))

  (define (run-timer)
    (let ((channel (make-channel))
          (name (service-canonical-name (current-service))))
      (spawn-fiber
       (lambda ()
         (let-loop loop ((processes '())          ;PID/start time
                         (past-runs (ring-buffer %past-run-log-size))
                         (occurrences occurrences)
                         (termination #f))

           (match (if (or termination
                          (zero? occurrences)
                          (and (pair? processes) wait-for-termination?))
                      (get-message channel)
                      (get-message* channel (seconds-to-wait event)
                                    'timeout 'overslept))
             (('terminate reply)
              ;; Terminate this timer and its processes.  Send #t on REPLY
              ;; when we're done.
              (local-output
               (l10n "Terminating timer '~a' with ~a process running."
                     "Terminating timer '~a' with ~a processes running."
                     (length processes))
               name (length processes))
              (for-each (match-lambda
                          ((pid . _)
                           (terminate-process pid termination-signal)))
                        processes)
              ;; If there are processes left, keep going until they're gone.
              (if (pair? processes)
                  (loop (termination reply))
                  (put-message reply #t)))
             (('process-terminated pid status)
              ;; Process PID completed.
              (let* ((start-time (assoc-ref processes pid))
                     (end-time ((@ (guile) current-time)))
                     (remaining (alist-delete pid processes))
                     (duration (- end-time start-time)))
                (local-output
                 (l10n "Process ~a of timer '~a' terminated with status ~a \
after ~a second."
                       "Process ~a of timer '~a' terminated with status ~a \
after ~a seconds."
                       duration)
                 pid name status
                 duration)
                (if (and termination (null? remaining))
                    (put-message termination #t) ;done
                    (begin
                      (when (zero? occurrences)
                        (stop-self))
                      (loop (processes remaining)
                            (past-runs
                             (ring-buffer-insert
                              (list status end-time start-time)
                              past-runs)))))))
             (('processes reply)
              (put-message reply processes)
              (loop))
             (('past-runs reply)
              (put-message reply past-runs)
              (loop))
             (('remaining-occurrences reply)
              (put-message reply occurrences)
              (loop))
             ('timeout
              ;; Time to perform ACTION.
              (if (command? action)
                  (let ((pid status (start-command
                                     (command-arguments action)
                                     #:log-file log-file
                                     #:user (command-user action)
                                     #:group (command-group action)
                                     #:supplementary-groups
                                     (command-supplementary-groups action)
                                     #:environment-variables
                                     (command-environment-variables action)
                                     #:directory (command-directory action)
                                     #:resource-limits
                                     (command-resource-limits action))))
                    (spawn-fiber
                     (lambda ()
                       (let ((status
                              (if max-duration
                                  (match (get-message* status max-duration
                                                       'timeout)
                                    ('timeout
                                     (local-output (l10n "Terminating \
process ~a of timer '~a' after maximum duration of ~a second."
                                                         "Terminating \
process ~a of timer '~a' after maximum duration of ~a seconds."
                                                         max-duration)
                                                   pid name max-duration)
                                     (terminate-process pid termination-signal)
                                     (get-message status))
                                    (result
                                     result))
                                  (get-message status))))
                         (put-message channel
                                      `(process-terminated ,pid ,status)))))

                    (local-output (l10n "Timer '~a' spawned process ~a.")
                                  name pid)
                    (loop (occurrences (- occurrences 1))
                          (processes
                           (alist-cons pid ((@ (guile) current-time))
                                       processes))))
                  (let ((start-time ((@ (guile) current-time))))
                    (define result
                      (catch #t
                        (lambda ()
                          (action)
                          'success)
                        (lambda (key . args)
                          (local-output
                           (l10n "Exception caught while calling action of \
timer '~a': ~s")
                           name (cons key args))
                          `(exception ,key ,@args))))

                    (when (= 1 occurrences)
                      (stop-self))
                    (loop (occurrences (- occurrences 1))
                          (past-runs
                           (ring-buffer-insert
                            (list result ((@ (guile) current-time)) start-time)
                            past-runs))))))

             ('overslept
              ;; Reached when resuming from sleep state: we slept
              ;; significantly more than the requested number of seconds.  To
              ;; avoid triggering every timer when resuming from sleep state,
              ;; sleep again to remain in sync.
              (local-output (l10n "Waiting anew for timer '~a' (resuming \
from sleep state?).")
                            name)
              (loop))))))

      (timer channel event action)))

  (lambda ()
    (assert (or (eqv? occurrences +inf.0)
                (and (integer? occurrences)
                     (exact? occurrences)
                     (positive? occurrences))))

    ;; First check that EVENT has matching events and return #f otherwise.
    (let ((now (time-utc->date (current-time time-utc))))
      (if (false-if-exception (next-calendar-event event now))
          (run-timer)
          (begin
            (local-output (l10n "No matching event for timer '~a': ~s.")
                          (service-canonical-name (current-service))
                          event)
            (local-output (l10n "This indicates that the calendar event \
is overly constrained."))
            #f)))))

(define (make-timer-destructor)
  "Return a procedure for the @code{stop} method of a service whose
constructor was given by @code{make-timer-destructor}."
  (lambda (timer)
    (let ((reply (make-channel)))
      (put-message (timer-channel timer) `(terminate ,reply))
      ;; Wait until child processes have terminated.
      (get-message reply))
    #f))

(define (trigger-timer timer)
  "Trigger the action associated with @var{timer} as if it had reached its
next calendar event."
  (if timer
      (begin
        (local-output (l10n "Triggering timer."))
        (put-message (timer-channel timer) 'timeout))

      ;; Properly report situations like 'herd trigger S' when S is stopped
      ;; and thus has a running value of #f.
      (local-output (l10n "Attempted to trigger a timer that is not running; \
doing nothing."))))

(define timer-trigger-action
  (action 'trigger trigger-timer
          "Trigger the action associated with this timer."))


;;;
;;; 'at'-like timer.
;;;

(define (invalid-argument message . args)
  "Raise an exception with the given @var{message} and format @var{args} using
a good old key/arguments exception, such that the message is properly
serialized as an action exception returned to the client, which, in turn, can
display it correctly."
  (apply throw 'wrong-type-arg #f message args '()))

(define (string->calendar-event str)
  "Parse @var{str}, a string such as @code{\"17:14\"}, and return the
corresponding calendar event."
  (define (hour? obj)
    (and (integer? obj) (exact? obj)
         (>= obj 0) (< obj 24)))
  (define (minute? obj)
    (and (integer? obj) (exact? obj)
         (>= obj 0) (< obj 60)))
  (define second? minute?)

  (match (string-split str #\:)
    (((= string->number (? hour? hour))
      (= string->number (? minute? minute)))
     (calendar-event #:seconds '(0)
                     #:minutes (list minute)
                     #:hours (list hour)))
    (((= string->number (? hour? hour))
      (= string->number (? minute? minute))
      (= string->number (? second? second)))
     (calendar-event #:seconds (list second)
                     #:minutes (list minute)
                     #:hours (list hour)))
    (_
     (invalid-argument (l10n "~a: invalid calendar time specification")
                       str))))

(define (timer-arguments->calendar-event+command spec)
  "Parse @var{spec}, a list of arguments passed to the @code{schedule} timer
action, and return two values: a calendar event and a command (list of
strings) to run on the first occurrence of that event.  Raise an error if
@var{spec} is invalid."
  (let loop ((spec spec)
             (event #f)
             (arguments '()))
    (match spec
      (()
       (unless event
         ;; TRANSLATORS: In the 'at TIME' string, only 'TIME' may be
         ;; translated.  It refers to the fact that the user ran 'herd
         ;; schedule timer COMMAND' instead of 'herd schedule timer at 12:00
         ;; COMMAND', say, where '12:00' is a possible value for TIME.
         (invalid-argument (l10n "Timer spec lacks 'at TIME'.")))
       (unless (pair? arguments)
         (invalid-argument (l10n "Timer spec lacks a command to run.")))
       (values event arguments))
      (("at" time-spec rest ...)
       (loop rest (string->calendar-event time-spec) arguments))
      ((lst ...)
       (loop '() event lst)))))

(define* (schedule-timer spec
                         #:key
                         (name (gensym "timer-"))
                         (requirement '())
                         (extra-environment-variables '())
                         (directory (default-service-directory))
                         log-file
                         user group)
  "Schedule a timer according to @var{spec}, a list of strings such as
@code{'(\"at\" \"12:00\" \"xlock\")}.  The resulting timer is a registered as
a transient timed service and started.  Raise an error if @var{spec} is
invalid."
  (define user-group
    (compose group:name getgrnam passwd:gid getpwnam))

  (define user-home
    (compose passwd:dir getpwnam))

  (let* ((event arguments (timer-arguments->calendar-event+command spec))
         (home (and=> user user-home))
         (timer (service (list name)
                         #:requirement requirement
                         #:transient? #t
                         #:respawn? #f
                         #:start
                         (make-timer-constructor
                          event
                          (command arguments
                                   #:user user
                                   #:group (or group (and=> user user-group))
                                   ;; FIXME: Should set #:supplementary-groups as
                                   ;; returned by 'getgrouplist' for USER.
                                   #:directory
                                   (or directory
                                       home (default-service-directory))
                                   #:environment-variables
                                   (let ((variables (append
                                                     extra-environment-variables
                                                     (default-environment-variables))))
                                     (if home
                                         (append variables
                                                 (list (string-append "HOME=" home)))
                                         variables)))
                          #:occurrences 1
                          #:log-file log-file)
                         #:stop (make-timer-destructor)
                         #:actions (list timer-trigger-action)
                         #:documentation
                         (l10n "Run the given command at the specified time
and terminate."))))

    ;; XXX: Would be good to error out instead of registering TIMER as a
    ;; replacement of another service with the same name.
    (register-services (list timer))
    (start-service timer)))

(define* (timer-service #:optional (provision '(timer))
                        #:key (requirement '()))
  "Return a timer service with the given @var{provision} and
@var{requirement}.  The service has a @code{schedule} action that lets users
schedule command execution similar to the venerable @command{at} command."
  (define schedule-action
    (action 'schedule
            (lambda (_ . args)
              (let ((command options (span string? args)))
                (apply schedule-timer command
                       #:requirement (list (first provision))
                       options)))
            (l10n "Schedule a program to run at a specific time.  For example,
'herd schedule timer at 10:00 -- mpg123 alarm.mp3' schedules the command that
follows '--' to run at 10AM.")))

  (service provision
           #:requirement requirement
           #:start (const #t)
           #:stop (const #f)
           #:actions (list schedule-action)
           #:documentation (l10n "Spawn programs at specified times.")))
