From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:49024) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fdN5g-00057H-DX for guix-patches@gnu.org; Wed, 11 Jul 2018 17:56:05 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fdN5e-0004N5-Uu for guix-patches@gnu.org; Wed, 11 Jul 2018 17:56:04 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:48116) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1fdN5e-0004Mz-R2 for guix-patches@gnu.org; Wed, 11 Jul 2018 17:56:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1fdN5e-0005CF-JB for guix-patches@gnu.org; Wed, 11 Jul 2018 17:56:02 -0400 Subject: [bug#32128] [PATCH 2/2] services: mcron: Add 'schedule' action. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Wed, 11 Jul 2018 23:55:04 +0200 Message-Id: <20180711215504.30221-2-ludo@gnu.org> In-Reply-To: <20180711215504.30221-1-ludo@gnu.org> References: <20180711215504.30221-1-ludo@gnu.org> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 32128@debbugs.gnu.org Inspired by . * gnu/services/mcron.scm (shepherd-schedule-action): New procedure. (mcron-shepherd-services): Add 'actions' field. * gnu/tests/base.scm (run-mcron-test)["schedule action"]: New test. * doc/guix.texi (Scheduled Job Execution): Mention 'herd schedule'. --- doc/guix.texi | 15 ++++++++++ gnu/services/herd.scm | 3 ++ gnu/services/mcron.scm | 67 +++++++++++++++++++++++++++++++----------- gnu/tests/base.scm | 7 +++++ 4 files changed, 75 insertions(+), 17 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 0a6b2244d..8f72ab2b8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10844,6 +10844,21 @@ gexps to introduce job definitions that are passed to mcron for more information on mcron job specifications. Below is the reference of the mcron service. +On a running system, you can use the @code{schedule} action of the service to +visualize the mcron jobs that will be executed next: + +@example +# herd schedule mcron +@end example + +@noindent +The example above lists the next five tasks that will be executed, but you can +also specify the number of tasks to display: + +@example +# herd schedule mcron 10 +@end example + @deffn {Scheme Procedure} mcron-service @var{jobs} [#:mcron @var{mcron}] Return an mcron service running @var{mcron} that schedules @var{jobs}, a list of gexps denoting mcron job specifications. diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index d882c232c..8c96b7073 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 5bee02a58..759d9c8b3 100644 --- a/gnu/services/mcron.scm +++ b/gnu/services/mcron.scm @@ -60,29 +60,62 @@ (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?) + (zero? (close-pipe pipe))) + (line + (display line) + (loop))))))))) + (define mcron-shepherd-services (match-lambda (($ mcron ()) ;nothing to do! '()) (($ 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/tests/base.scm b/gnu/tests/base.scm index 0efb4a6e5..f27064af8 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -632,6 +632,13 @@ non-ASCII names from /tmp.") (wait-for-file "/root/witness-touch" marionette #:read '(@ (ice-9 rdelim) read-string))) + ;; Make sure the 'schedule' action is accepted. + (test-equal "schedule action" + '(#t) ;one value, #t + (marionette-eval '(with-shepherd-action 'mcron ('schedule) result + result) + marionette)) + (test-end) (exit (= (test-runner-fail-count (test-runner-current)) 0))))) -- 2.18.0