diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/herd.scm | 3 | ||||
| -rw-r--r-- | gnu/services/mcron.scm | 76 | ||||
| -rw-r--r-- | gnu/services/shepherd.scm | 23 | ||||
| -rw-r--r-- | gnu/services/virtualization.scm | 1 |
4 files changed, 85 insertions, 18 deletions
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index d882c232cf..8c96b70731 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -45,6 +45,7 @@ live-service-requirement live-service-running + with-shepherd-action current-services unload-services unload-service @@ -168,6 +169,8 @@ return #f." (define-syntax-rule (with-shepherd-action service (action args ...) result body ...) + "Invoke ACTION on SERVICE with the given ARGS, and evaluate BODY with RESULT +bound to the action's result." (invoke-action service action (list args ...) (lambda (result) body ...))) diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm index 5bee02a587..5757bf8cf6 100644 --- a/gnu/services/mcron.scm +++ b/gnu/services/mcron.scm @@ -60,29 +60,71 @@ (define (job-file job) (scheme-file "mcron-job" job)) +(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 with race between 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)) + (let ((files (map job-file 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))))) + (stop #~(make-kill-destructor)) - ;; 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))))))) + (actions + (list (shepherd-schedule-action mcron files))))))))) (define mcron-service-type (service-type (name 'mcron) diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 6ca53faa3d..4cd2249841 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -49,6 +49,12 @@ shepherd-service-auto-start? shepherd-service-modules + shepherd-action + shepherd-action? + shepherd-action-name + shepherd-action-documentation + shepherd-action-procedure + %default-modules shepherd-service-file @@ -146,11 +152,20 @@ DEFAULT is given, use it as the service's default value." (start shepherd-service-start) ;g-expression (procedure) (stop shepherd-service-stop ;g-expression (procedure) (default #~(const #f))) + (actions shepherd-service-actions ;list of <shepherd-action> + (default '())) (auto-start? shepherd-service-auto-start? ;Boolean (default #t)) (modules shepherd-service-modules ;list of module names (default %default-modules))) +(define-record-type* <shepherd-action> + shepherd-action make-shepherd-action + shepherd-action? + (name shepherd-action-name) ;symbol + (procedure shepherd-action-procedure) ;gexp + (documentation shepherd-action-documentation)) ;string + (define (shepherd-service-canonical-name service) "Return the 'canonical name' of SERVICE." (first (shepherd-service-provision service))) @@ -223,7 +238,13 @@ stored." #:requires '#$(shepherd-service-requirement service) #:respawn? '#$(shepherd-service-respawn? service) #:start #$(shepherd-service-start service) - #:stop #$(shepherd-service-stop service)))))) + #:stop #$(shepherd-service-stop service) + #:actions + (make-actions + #$@(map (match-lambda + (($ <shepherd-action> name proc doc) + #~(#$name #$doc #$proc))) + (shepherd-service-actions service)))))))) (define (shepherd-configuration-file services) "Return the shepherd configuration file for SERVICES." diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index bf71e7f26a..705ed84d06 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -37,6 +37,7 @@ #:export (libvirt-configuration libvirt-service-type + virtlog-configuration virtlog-service-type %qemu-platforms |