;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (gnu services mcron)
#:use-module (gnu services)
- #:use-module (gnu services base)
#:use-module (gnu services shepherd)
- #:autoload (gnu packages guile) (mcron2)
+ #:use-module (gnu packages guile-xyz)
+ #:use-module (guix deprecation)
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module (srfi srfi-1)
make-mcron-configuration
mcron-configuration?
(mcron mcron-configuration-mcron ;package
- (default mcron2))
+ (default mcron))
(jobs mcron-configuration-jobs ;list of <mcron-job>
(default '())))
-(define (job-file job)
- (scheme-file "mcron-job" job))
+(define (job-files mcron jobs)
+ "Return a list of file-like object for JOBS, a list of gexps."
+ (define (validated-file job)
+ ;; This procedure behaves like 'scheme-file' but it runs 'mcron
+ ;; --schedule' to detect any error in JOB.
+ (computed-file "mcron-job"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (call-with-output-file "prologue"
+ (lambda (port)
+ ;; This prologue allows 'mcron --schedule' to
+ ;; proceed no matter what #:user option is passed
+ ;; to 'job'.
+ (write '(set! getpw
+ (const (getpwuid (getuid))))
+ port)))
+
+ (call-with-output-file "job"
+ (lambda (port)
+ (write '#$job port)))
+
+ (invoke #+(file-append mcron "/bin/mcron")
+ "--schedule=20" "prologue" "job")
+ (copy-file "job" #$output)))
+ #:options '(#:env-vars (("COLUMNS" . "150")))))
+
+ (map validated-file jobs))
+
+(define (shepherd-schedule-action mcron files)
+ "Return a Shepherd action that runs MCRON with '--schedule' for the given
+files."
+ (shepherd-action
+ (name 'schedule)
+ (documentation
+ "Display jobs that are going to be scheduled.")
+ (procedure
+ #~(lambda* (_ #:optional (n "5"))
+ ;; XXX: This is a global side effect.
+ (setenv "GUILE_AUTO_COMPILE" "0")
+
+ ;; Run 'mcron' in a pipe so we can explicitly redirect its output to
+ ;; 'current-output-port', which at this stage is bound to the client
+ ;; connection.
+ (let ((pipe (open-pipe* OPEN_READ
+ #$(file-append mcron "/bin/mcron")
+ (string-append "--schedule=" n)
+ #$@files)))
+ (let loop ()
+ (match (read-line pipe 'concat)
+ ((? eof-object?)
+ (catch 'system-error
+ (lambda ()
+ (zero? (close-pipe pipe)))
+ (lambda args
+ ;; There's a race with the SIGCHLD handler, which
+ ;; could call 'waitpid' before 'close-pipe' above does. If
+ ;; we get ECHILD, that means we lost the race, but that's
+ ;; fine.
+ (or (= ECHILD (system-error-errno args))
+ (apply throw args)))))
+ (line
+ (display line)
+ (loop)))))))))
(define mcron-shepherd-services
(match-lambda
(($ <mcron-configuration> mcron ()) ;nothing to do!
'())
(($ <mcron-configuration> mcron jobs)
- (list (shepherd-service
- (provision '(mcron))
- (requirement '(user-processes))
- (modules `((srfi srfi-1)
- (srfi srfi-26)
- ,@%default-modules))
- (start #~(make-forkexec-constructor
- (list (string-append #$mcron "/bin/mcron")
- #$@(map job-file jobs))
-
- ;; Disable auto-compilation of the job files and set a
- ;; sane value for 'PATH'.
- #:environment-variables
- (cons* "GUILE_AUTO_COMPILE=0"
- "PATH=/run/current-system/profile/bin"
- (remove (cut string-prefix? "PATH=" <>)
- (environ)))))
- (stop #~(make-kill-destructor)))))))
+ (let ((files (job-files mcron jobs)))
+ (list (shepherd-service
+ (provision '(mcron))
+ (requirement '(user-processes))
+ (modules `((srfi srfi-1)
+ (srfi srfi-26)
+ (ice-9 popen) ;for the 'schedule' action
+ (ice-9 rdelim)
+ (ice-9 match)
+ ,@%default-modules))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$mcron "/bin/mcron") #$@files)
+
+ ;; Disable auto-compilation of the job files and set a
+ ;; sane value for 'PATH'.
+ #:environment-variables
+ (cons* "GUILE_AUTO_COMPILE=0"
+ "PATH=/run/current-system/profile/bin"
+ (remove (cut string-prefix? "PATH=" <>)
+ (environ)))
+
+ #:log-file "/var/log/mcron.log"))
+ (stop #~(make-kill-destructor))
+
+ (actions
+ (list (shepherd-schedule-action mcron files)))))))))
(define mcron-service-type
(service-type (name 'mcron)
+ (description
+ "Run the mcron job scheduling daemon.")
(extensions
(list (service-extension shepherd-root-service-type
mcron-shepherd-services)
jobs)))))
(default-value (mcron-configuration)))) ;empty job list
-(define* (mcron-service jobs #:optional (mcron mcron2))
+(define-deprecated (mcron-service jobs #:optional (mcron mcron))
+ mcron-service-type
"Return an mcron service running @var{mcron} that schedules @var{jobs}, a
list of gexps denoting mcron job specifications.
HCoop / jackhill / guix / guix.git / blobdiff