[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 02/02: DRAFT Add timer service.
|
From: |
Ludovic Courtès |
|
Subject: |
[shepherd] 02/02: DRAFT Add timer service. |
|
Date: |
Fri, 15 Mar 2024 19:06:05 -0400 (EDT) |
civodul pushed a commit to branch wip-timers
in repository shepherd.
commit c930551fdc2d9b02c50111f1198a1c0b0eeae372
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Mar 16 00:04:00 2024 +0100
DRAFT Add timer service.
DRAFT Actual service is missing.
* modules/shepherd/service/timer.scm,
tests/services/timer.scm: New files.
* Makefile.am (dist_servicesub_DATA, TESTS): Add them.
---
Makefile.am | 8 +-
modules/shepherd/service/timer.scm | 275 +++++++++++++++++++++++++++++++++++++
tests/services/timer.scm | 73 ++++++++++
3 files changed, 353 insertions(+), 3 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 25f7429..ccff59d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,6 +1,6 @@
# Makefile.am -- How to build and install the Shepherd.
# Copyright © 2002, 2003 Wolfgang Jährling <wolfgang@pro-linux.de>
-# Copyright © 2013-2016, 2018-2020, 2022-2023 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013-2016, 2018-2020, 2022-2024 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2018 Carlo Zancanaro <carlo@zancanaro.id.au>
# Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
#
@@ -49,7 +49,8 @@ nodist_shepherdsub_DATA = \
modules/shepherd/system.scm
dist_servicesub_DATA = \
modules/shepherd/service/monitoring.scm \
- modules/shepherd/service/repl.scm
+ modules/shepherd/service/repl.scm \
+ modules/shepherd/service/timer.scm
shepherdgosubdir = $(guileobjectdir)/shepherd
servicegosubdir = $(guileobjectdir)/shepherd/service
@@ -277,7 +278,8 @@ TESTS = \
tests/daemonize.sh \
tests/eval-load.sh \
tests/services/monitoring.sh \
- tests/services/repl.sh
+ tests/services/repl.sh \
+ tests/services/timer.scm
TEST_EXTENSIONS = .sh .scm
EXTRA_DIST += $(TESTS)
diff --git a/modules/shepherd/service/timer.scm
b/modules/shepherd/service/timer.scm
new file mode 100644
index 0000000..6a786ea
--- /dev/null
+++ b/modules/shepherd/service/timer.scm
@@ -0,0 +1,275 @@
+;; timer.scm -- Timer service.
+;; Copyright (C) 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 (shepherd service timer)
+ #:use-module (shepherd service)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 match)
+ #:export (calendar-event
+ calendar-event?
+ calendar-event-months
+ calendar-event-days-of-month
+ calendar-event-days-of-week
+ calendar-event-hours
+ calendar-event-minutes
+
+ next-calendar-event))
+
+;; herd list timer -> shows current timers like 'systemctl list-timers'
+;; herd at timer TIME COMMAND -> like 'at'
+;; herd stop timer -> stop all the timers
+;; herd stop foo-timer -> stop specific timed service
+
+;; Vixie:
+;; "minute hour day-of-month month day-of-week"
+
+(define-record-type <calendar-event>
+ (%calendar-event minutes hours days-of-month months days-of-week)
+ calendar-event?
+ (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 any-minute (iota 60))
+(define any-hour (iota 24))
+(define any-day-of-month (iota 31 1))
+(define any-month (iota 12 1))
+(define* (calendar-event #:key
+ (minutes any-minute)
+ (hours any-hour)
+ days-of-week
+ (days-of-month
+ (and (not days-of-week) any-day-of-month))
+ (months any-month))
+ (%calendar-event minutes hours days-of-month months 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 (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 (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)
+ (let loop ((candidates (sort days
+ (sooner (date-day date)
+ (days-in-month (date-month date)
+ (date-year date))))))
+ (match candidates
+ ((first . rest)
+ (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)
+ #;(make-date 0 0 0 0
+ first (date-month next) (date-year next) ; ; ; ; ; ;
+ (date-zone-offset next))))))))
+
+(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)
+ #;(make-date 0 0 0 next
+ (date-day next) (date-month next) (date-year next) ; ; ; ; ; ;
+ (date-zone-offset next))))))))
+
+(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)
+ #;(make-date 0 0 0 next
+ (date-day next) (date-month next) (date-year next) ; ; ; ; ; ;
+ (date-zone-offset next))))))))
+
+(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 (next-calendar-event event)
+ "Return a procedure that, given a date object, returns the next date that
+matches @var{event}."
+ (define (month date)
+ (if (memv (date-month date) (calendar-event-months event))
+ date
+ (fit-month date (calendar-event-months event))))
+
+ (define (day date)
+ (let ((days (append
+ (or (calendar-event-days-of-month event) '())
+ (match (calendar-event-days-of-week event)
+ (#f
+ '())
+ (days (week-days->month-days days
+ (date-month date)
+ (date-year date)))))))
+ (if (memv (date-day date) days)
+ date
+ (fit-day date days))))
+
+ (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)
+ ;; Clear seconds and nanoseconds and jump to the next minute.
+ (increment-minute (set-date-nanosecond (set-date-second date 0) 0)))
+
+ (lambda (date)
+ ;; TODO: Adjust timezone.
+ (month (day (hour (minute (second date)))))))
+
+(define (seconds-to-wait event)
+ "Return the number of seconds to wait before the next occurrence of
+@var{event}."
+ (let* ((now (current-time time-utc))
+ (then ((next-calendar-event event) (time-utc->date now))))
+ (time-second (time-difference (date->time-utc then) now))))
+
+
+(define (make-timer-constructor event command)
+ (lambda ()
+ (let ((timer (lookup-service 'timer))
+ (wakeup (make-channel)))
+ (put-message (service-control timer)
+ `(register ,(current-service)
+ ,spec ,wakeup))
+ (spawn-fiber
+ (lambda ()
+ (let loop ()
+ (match (get-message* wakeup (seconds-to-wait event))
+ ('terminate
+ #t)
+ ('timeout
+ (spawn-command (command-line command)
+ #:user (command-user command)
+ #:group (command-group command)
+ #:environment-variables
+ (command-environment-variables command)
+ #:directory (command-directory command)
+ #:resource-limits
+ (command-resource-limits command))
+ (loop))))))
+ wakeup)))
+
+(define (make-timer-destructor)
+ (lambda (wakeup)
+ (put-message wakeup 'terminate)
+ #f))
diff --git a/tests/services/timer.scm b/tests/services/timer.scm
new file mode 100644
index 0000000..689597c
--- /dev/null
+++ b/tests/services/timer.scm
@@ -0,0 +1,73 @@
+;; 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 timer)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-64))
+
+(test-begin "timer")
+
+(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 ((next (next-calendar-event
+ (calendar-event #:hours '(6 12 18)
+ #:minutes '(30)
+ ;; Sunday, Wednesday, Saturday
+ #:days-of-week '(0 3 6)))))
+ (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 date)))
+ (loop date (+ 1 n) (cons date result)))
+ (reverse result)))))
+
+(test-end "timer")