[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] base: Annotate output with job information.
|
From: |
Maxim Cournoyer |
|
Subject: |
[PATCH] base: Annotate output with job information. |
|
Date: |
Tue, 17 Aug 2021 19:32:18 -0400 |
Before this change, it was difficult to discern which job emitted which
output, as there was no information connecting the job to the output it
produced. This change rectifies that by annotating each line output by
cron/mcron with a prefix that contains a timestamp and the job name. It also
reports about when the job runs and whether it completed successfully or
failed. It was initially suggested here: <https://issues.guix.gnu.org/36510>.
* src/mcron/base.scm (%date-format, %log-format): New parameters.
(validate-date-format, validate-log-format): New procedures.
(<job-data>): New record.
(run-job): Update doc. Redirect stdout and stderr to a pipe. Return a
<job-data> instance containing the input port and other information about the
job. Output job status messages.
(%child-fdes-buffers): New variable.
(process-output): New procedure.
(child-cleanup): Add docstring. Use positive logic. Call 'process-output'
one last time after a child process is collected.
(run-job-loop): Add a CHILDREN-DATA variable to the loop. Provide the open
file descriptors of the children ports to select*, and collect their output
when they trigger select.
* tests/base.scm ("run-job: basic"): Adjust and fix indentation.
(dummy-job/capture-output): New procedure.
("run-job, output"): New test.
("validate-date-format, valid", "validate-date-format, invalid")
("validate-log-format, valid", "validate-log-format, invalid")
("run-job, output with custom format", "run-job, failure")
("run-job, failure in shell action"): New tests.
* src/mcron/scripts/cron.scm (show-help): Document new options.
(%options) [log-format, date-format]: New options.
(main): Parameterize the main loop with the new parameter options (or their
default values when not provided); move exception handling elsewhere (see
below).
* src/mcron/scripts/mcron.scm: Likewise.
* src/cron.in: Install error handler here.
* src/mcron.in: Likewise.
* doc/mcron.texi: Document new cron and mcron options, as well as new
(mcron base) APIs.
* tests/basic.sh: Test the new options.
Suggested-by: Robert Vollmert <rob@vllmrt.net>
---
doc/mcron.texi | 84 ++++++++++
src/cron.in | 3 +-
src/mcron.in | 5 +-
src/mcron/base.scm | 297 +++++++++++++++++++++++++++++-------
src/mcron/scripts/cron.scm | 77 +++++-----
src/mcron/scripts/mcron.scm | 20 ++-
tests/base.scm | 106 +++++++++++--
tests/basic.sh | 13 ++
8 files changed, 484 insertions(+), 121 deletions(-)
diff --git a/doc/mcron.texi b/doc/mcron.texi
index 70ab38c..1c404b7 100644
--- a/doc/mcron.texi
+++ b/doc/mcron.texi
@@ -13,6 +13,7 @@ program for running jobs at scheduled times.
Copyright @copyright{} 2003, 2005, 2006, 2012, 2014 Dale Mellor
Copyright @copyright{} 2018 Mathieu Lirzin
+Copyright @copyright{} 2021 Maxim Cournoyer
@quotation
Permission is granted to copy, distribute and/or modify this
@@ -872,6 +873,53 @@ This option is used to indicate whether the configuration
information
being passed on the standard input is in Vixie format or Guile
format. Guile is the default.
+@cindex log-format option
+@cindex options, log-format
+@cindex --log-format option
+@cindex logging output, configuration
+@cindex configuring the logging output
+@anchor{--log-format}
+@item --log-format
+This option accepts an @code{(ice-9 format)} format string that can be used to
+customize the appearance of the output. The format string is applied to
+@code{format} with the following four arguments:
+@enumerate
+@item A date/time string.
+@item The job process PID (as as number).
+@item The action name.
+@item The message to log.
+@end enumerate
+
+It defaults to @code{"~a ~2@*~a: ~a~%"}, which produces output messages like:
+
+@example
+2021-08-17T12:01:01 some-job: completed in 0.218s
+@end example
+
+If you'd rather see the job process PID instead of a timestamp, you could
+instead specify the format string as @code{"~1@*~a ~a: ~a~%"}, which would
+result in something like:
+
+@example
+39234 some-job: completed in 0.218s
+@end example
+
+To learn about all the possibilities offered by @code{(ice-9 format)}, refer
+to @ref{Formatted Output,,, guile, GNU@tie{}Guile@tie{}Reference@tie{}Manual}.
+
+@cindex date-format option
+@cindex options, date-format
+@cindex --date-format option
+@cindex timestamp, modification
+@cindex changing the default timestamp
+@anchor{--date-format}
+@item --date-format
+This option accepts a @code{(srfi srfi-19)} date string format, to customize
+the appearance of the timestamp in output messages. It defaults to
+@code{"~5"}, which corresponds to a local ISO-8601 date/time format
+(@pxref{SRFI-19 Date to string,,,
+guile,GNU@tie{}Guile@tie{}Reference@tie{}Manual}).
+
@cindex -v option
@cindex --version option
@cindex options, -v
@@ -966,6 +1014,12 @@ minute to check for modifications to @code{/etc/crontab}.
It is
recommended that this option be used (and further that the
@code{/etc/crontab} file be taken off the system altogether!)
+@item --log-format
+Analogous to mcron's @ref{--log-format}.
+
+@item --date-format
+Analogous to mcron's @ref{--date-format}.
+
@end table
@node Invoking crontab, Behaviour on laptops, Invoking cron or crond, Invoking
@@ -1251,6 +1305,36 @@ last job that was reported in the schedule report. The
report itself
is returned to the calling program as a string.
@end deffn
+@defopt %date-format
+@cindex parameters, date format
+@cindex date format parameter
+This parameter holds the @code{(srfi srfi-19)} format string used to produce
+the timestamp found in output messages. It defaults to @code{"~5"}.
+@end defopt
+
+@deffn{Scheme procedure} validate-date-format @var{fmt}
+@cindex date format validator
+This procedure is used to validate @var{fmt}, a @code{(srfi srfi-19)} format
+string. When @var{fmt} is invalid, an error message is displayed and the
+program is aborted.
+@end deffn
+
+@defopt %log-format
+@cindex parameters, log format
+@cindex log format parameter
+This parameter holds the @code{(ice-9 format)} format string used to produce
+the output messages. The four arguments applied to format are the timestamp,
+the process PID, the job name and the message. It defaults to @code{"~a
+~2@*~a: ~a~%"}.
+@end defopt
+
+@deffn{Scheme procedure} validate-log-format @var{fmt}
+@cindex log format validator
+This procedure is used to validate @var{fmt}, a @code{(ice-9 format)} format
+string. When @var{fmt} is invalid, an error message is displayed and the
+program is aborted.
+@end deffn
+
@node The redirect module, The vixie-time module, The base module, Guile
modules
@section The redirect module
@cindex redirect module
diff --git a/src/cron.in b/src/cron.in
index 25ad273..be624e0 100644
--- a/src/cron.in
+++ b/src/cron.in
@@ -7,4 +7,5 @@
(set! %load-compiled-path (cons "%modbuilddir%" %load-compiled-path)))
(use-modules (mcron scripts cron))
-(main)
+(use-modules (mcron utils))
+(catch-mcron-error (main))
diff --git a/src/mcron.in b/src/mcron.in
index 268743c..07023f9 100644
--- a/src/mcron.in
+++ b/src/mcron.in
@@ -6,5 +6,6 @@
(set! %load-path (cons "%modsrcdir%" %load-path))
(set! %load-compiled-path (cons "%modbuilddir%" %load-compiled-path)))
-(use-modules (mcron scripts mcron))
-(main)
+(use-modules (mcron scripts mcron)
+ (mcron utils))
+(catch-mcron-error (main))
diff --git a/src/mcron/base.scm b/src/mcron/base.scm
index 037a9b7..17bab69 100644
--- a/src/mcron/base.scm
+++ b/src/mcron/base.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net>
;;; Copyright © 2015, 2016, 2018 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Mcron.
;;;
@@ -26,18 +27,28 @@
;;;; Code:
(define-module (mcron base)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 control)
+ #:use-module (ice-9 textual-ports)
#:use-module (mcron environment)
#:use-module (mcron utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
+ #:use-module ((srfi srfi-19) #:prefix srfi-19:)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-111)
#:export (add-job
remove-user-jobs
display-schedule
run-job-loop
+
+ %date-format
+ %log-format
+ validate-date-format
+ validate-log-format
+
;; Deprecated and undocumented procedures.
use-system-job-list
use-user-job-list
@@ -71,6 +82,46 @@
(user schedule-user set-schedule-user!) ;list of <job>
(current schedule-current set-schedule-current!)) ;symbol 'user or 'system
+;; A (srfi srfi-19) format string for the date. It is used to format the
+;; timestamp argument. Defaults to the local ISO-8601 date/time format.
+(define %date-format (make-parameter "~5"))
+
+(define (validate-date-format fmt)
+ "Validate that FMT is a valid srfi-19 date format string."
+ (let ((time (srfi-19:current-time)))
+ (unless (false-if-exception
+ (srfi-19:date->string (srfi-19:time-utc->date time) fmt))
+ (throw 'mcron-error 1 "invalid srfi-19 date format string
+hint: consult 'info \"(guile) SRFI-19 Date to string\"'"))))
+
+;; An (ice-9 format) format string. The positional arguments applied to
+;; format are:
+;; 1. the timestamp;
+;; 2. the job process PID;
+;; 3. the action name;
+;; 4. the message.
+(define %log-format (make-parameter "~a ~2@*~a: ~a~%"))
+
+(define (validate-log-format fmt)
+ "Validate that FMT is a valid (ice-9 format) log format string."
+ (unless (with-output-to-port (%make-void-port "w")
+ (lambda ()
+ (with-error-to-port (%make-void-port "w")
+ (lambda ()
+ (false-if-exception
+ (format #f "~@?" fmt
+ "2021-08-17T15:23:12" 39143 "dummy" "message"))))))
+ (throw 'mcron-error 1 "invalid (ice-9 format) format string
+hint: consult 'info \"(guile) Formatted Output\"'")))
+
+;; Data about a running job process.
+(define-record-type <job-data>
+ (make-job-data pid port name)
+ job-data?
+ (pid job-data:pid) ;string : the job process PID
+ (port job-data:port) ;port : an input
+ (name job-data:name)) ;string : the name of the job action
+
(define %global-schedule
;; Global schedule used by 'mcron' and 'cron'.
(make-schedule '() '() 'user))
@@ -172,57 +223,164 @@ unusable."
;; Apply PROC to the value stored in 'number-children'.
(set-box! number-children (proc (unbox number-children))))
-(define (run-job job)
- "Run JOB in a separate process. The process is run as JOB user with the
+(define* (run-job job)
+ "Run JOB in a separate process. The process is run as JOB user with the
environment properly set. Update the NEXT-TIME field of JOB by computing its
-next value."
- (if (= (primitive-fork) 0)
- (dynamic-wind ;child
- (const #t)
- (λ ()
- (setgid (passwd:gid (job:user job)))
- (setuid (passwd:uid (job:user job)))
- ;; Handle the case where the home directory points to a nonexistent
- ;; location, as can be the case when running the job as the "nobody"
- ;; user.
- (catch 'system-error
- (lambda ()
- (chdir (passwd:dir (job:user job))))
- (lambda args
- (let ((errno (system-error-errno args)))
- (cond
- ((= ENOENT errno) (chdir "/"))
- (else (throw 'system-error args))))))
- (modify-environment (job:environment job) (job:user job))
- ((job:action job)))
- (λ ()
- (primitive-exit 0)))
- (begin ;parent
- (update-number-children! 1+)
- (job:next-time-set! job ((job:next-time-function job)
- (current-time))))))
-
-(define (child-cleanup)
- ;; Give any zombie children a chance to die, and decrease the number known
- ;; to exist.
- (unless (or (<= (unbox number-children) 0)
- (= (car (waitpid WAIT_ANY WNOHANG)) 0))
- (update-number-children! 1-)
- (child-cleanup)))
-
-(define* (run-job-loop #:optional fd-list #:key (schedule %global-schedule))
- ;; Loop over all job specifications, get a list of the next ones to run (may
- ;; be more than one). Set an alarm and go to sleep. When we wake, run the
- ;; jobs and reap any children (old jobs) that have completed. Repeat ad
- ;; infinitum.
- ;;
+next value. Return a <job-data> record object containing the job process
+PID, the input pipe from which the process standard output and standard error
+streams can be read as well as the name of the job."
+ (define start (srfi-19:current-time srfi-19:time-monotonic)) ;start time
+
+ (define (seconds-since start)
+ ;; Return the time elapsed in seconds since START.
+ (let* ((end (srfi-19:current-time srfi-19:time-monotonic))
+ (elapsed (srfi-19:time-difference end start)))
+ (+ (srfi-19:time-second elapsed)
+ (* 1e-9 (srfi-19:time-nanosecond elapsed)))))
+
+ (define child->parent-pipe (pipe))
+
+ ;; Empty buffers to avoid duplicated output.
+ (flush-all-ports)
+
+ (match (primitive-fork)
+ (0 ;child
+ ;; Prepare the environment.
+
+ ;; Connect the stdout and stderr outputs of the child process to the
+ ;; pipe established in the parent.
+ (close (car child->parent-pipe)) ;unused input pipe
+ (dup2 (port->fdes (cdr child->parent-pipe)) 1)
+ (dup2 1 2)
+ (set-current-output-port (cdr child->parent-pipe))
+ (set-current-error-port (cdr child->parent-pipe))
+
+ (setgid (passwd:gid (job:user job)))
+ (setuid (passwd:uid (job:user job)))
+ ;; Handle a nonexistent home directory, as can be the case when running
+ ;; the job as the "nobody" user.
+ (catch 'system-error
+ (lambda ()
+ (chdir (passwd:dir (job:user job))))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond
+ ((= ENOENT errno) (chdir "/"))
+ (else (throw 'system-error args))))))
+ (modify-environment (job:environment job) (job:user job))
+
+ ;; Execute the action.
+ (catch #t
+ (lambda ()
+ (format #t "running...~%")
+ (let* ((result ((job:action job)))
+ (exit-val/maybe (false-if-exception
+ (status:exit-val result))))
+ (when (and exit-val/maybe
+ (not (= 0 exit-val/maybe)))
+ (error "unclean exit status" exit-val/maybe)))
+ (format #t "completed in ~,3fs~%" (seconds-since start))
+ (primitive-exit 0))
+ (lambda args
+ (format (current-error-port) "failed after ~,3fs with: ~a~%"
+ (seconds-since start) args)
+ (primitive-exit 1))))
+ (child-pid ;parent
+ (update-number-children! 1+)
+ (job:next-time-set! job ((job:next-time-function job)
+ (current-time)))
+ (close (cdr child->parent-pipe)) ;disconnect the write end of the pipe
+ (make-job-data child-pid (car child->parent-pipe) (job:displayable
job)))))
+
+(define %child-fdes-buffers
+ ;; A map of the retrieved output of the children processes, indexed by their
+ ;; file descriptor number.
+ (make-hash-table 10))
+
+(define* (process-output children-data)
+ "Read the child processes output from their input port recorded in
+CHILDREN-DATA and print an annotated version of each line to the standard
+output port. Ports are closed and their output flushed upon reading the EOF
+character."
+ (define (retrieve-output port)
+ (if (eof-object? (peek-char port))
+ (begin ;nothing left to read
+ (close port)
+ '())
+ (let* ((fdes (port->fdes port))
+ (output (string-append
+ (or (hash-ref %child-fdes-buffers fdes) "")
+ (get-string-all port)))
+ (last-newline (string-index-right output #\newline))
+ (partial-output (and last-newline
+ (string-drop output
+ (1+ last-newline))))
+ (complete-output (if last-newline
+ (string-take output last-newline)
+ output)))
+ ;; Preserve partial output until next read.
+ (hash-set! %child-fdes-buffers fdes partial-output)
+ (string-split complete-output #\newline))))
+
+ (define timestamp (srfi-19:date->string
+ (srfi-19:time-monotonic->date
+ (srfi-19:current-time srfi-19:time-monotonic))
+ (%date-format)))
+
+ ;; Use line buffering so the output is printed in "real time".
+ (setvbuf (current-output-port) 'line)
+
+ (for-each (lambda (data)
+ (let* ((name (job-data:name data))
+ (pid (job-data:pid data)))
+ (for-each (lambda (line)
+ (format #t "~@?" (%log-format)
+ timestamp pid name line))
+ (retrieve-output (job-data:port data)))))
+ ;; Dismiss already closed ports.
+ (filter (compose (negate port-closed?)
+ job-data:port)
+ children-data)))
+
+(define (child-cleanup children-data)
+ "Give any zombie children a chance to die, and decrease the number known to
+exist. CHILDREN-DATA is a list of <job-data> objects. Return the pruned list
+of CHILDREN-DATA."
+ (define has-children? (> (unbox number-children) 0))
+ (define collected-pid (or (and has-children?
+ (car (waitpid WAIT_ANY WNOHANG)))
+ 0))
+ (define (match-collected-pid? job-data)
+ (= (job-data:pid job-data) collected-pid))
+
+ (if (and has-children?
+ (not (= 0 collected-pid))) ;at least one process was collected
+ (begin
+ (update-number-children! 1-)
+ ;; Fully collect the output of the reaped child process.
+ (and=> (find match-collected-pid? children-data)
+ (lambda (child-data)
+ (process-output (list child-data))))
+ (child-cleanup (remove match-collected-pid? children-data)))
+ children-data))
+
+(define* (run-job-loop #:optional (fd-list '())
+ #:key (schedule %global-schedule))
+ "Loop over all job specifications in SCHEDULE, get a list of the next ones
+to run (may be more than one). Set an alarm and go to sleep. When we wake,
+run the jobs and reap any children (old jobs) that have completed. Repeat ad
+infinitum."
+ ;; Validate the format parameters, so that we can fail early
+ (validate-date-format (%date-format))
+ (validate-log-format (%log-format))
+
;; Note that, if we wake ahead of time, it can only mean that a signal has
;; been sent by a crontab job to tell us to re-read a crontab file. In this
;; case we break out of the loop here, and let the main procedure deal with
;; the situation (it will eventually re-call this function, thus maintaining
;; the loop).
(cond-expand
- ((or guile-3.0 guile-2.2) ;2.2 and 3.0
+ ((or guile-3.0 guile-2.2) ;2.2 and 3.0
(define select* select))
(else
;; On Guile 2.0, 'select' could throw upon EINTR or EAGAIN.
@@ -236,23 +394,44 @@ next value."
(apply throw args)))))))
(let/ec break
- (let loop ()
+ (let loop ((children-data '())) ;list of <job-data> objects
(match (find-next-jobs #:schedule schedule)
((next-time . next-jobs-lst)
- (let ((sleep-time (if next-time
- (- next-time (current-time))
- 2000000000)))
+ (let* ((sleep-time (if next-time
+ (- next-time (current-time))
+ 2000000000))
+ (ports (map job-data:port children-data))
+ ;; Ensure closed ports are not put back into select, otherwise
+ ;; it would not block and EOFs would be read infinitely.
+ (children-fdes (filter-map (lambda (p)
+ (and (not (port-closed? p))
+ (port->fdes p)))
+ ports)))
(when (> sleep-time 0)
- (match (select* fd-list '() '() sleep-time)
+ (match (select* (append fd-list children-fdes)
+ '() '() sleep-time)
((() () ())
;; 'select' returned an empty set, perhaps because it got
- ;; EINTR or EAGAIN. It's a good time to wait for child
- ;; processes.
- (child-cleanup))
- (((lst ...) () ())
- ;; There's some activity so leave the loop.
- (break))))
-
- (for-each run-job next-jobs-lst)
- (child-cleanup)
- (loop)))))))
+ ;; EINTR or EAGAIN.
+ (loop (child-cleanup children-data)))
+ (((fdes ...) () ())
+ ;; Process any children input fdes ready to be read.
+ (let ((children-fdes/read-ready (lset-intersection
+ = children-fdes fdes)))
+ (when (not (null? (lset-difference
+ = fdes children-fdes/read-ready)))
+ ;; There was some crontab activity so leave the loop to
+ ;; process the update request.
+ (break))
+ (unless (null? children-fdes/read-ready)
+ (process-output
+ (filter (lambda (x)
+ (member (port->fdes (job-data:port x))
+ children-fdes/read-ready))
+ children-data))
+ (loop (child-cleanup children-data)))))))
+
+ ;; The timeout has elapsed. Run the scheduled job(s).
+ (let ((new-children-data (map run-job next-jobs-lst))
+ (pruned-children-data (child-cleanup children-data)))
+ (loop (append new-children-data pruned-children-data)))))))))
diff --git a/src/mcron/scripts/cron.scm b/src/mcron/scripts/cron.scm
index 25c8a1a..a0c9a68 100644
--- a/src/mcron/scripts/cron.scm
+++ b/src/mcron/scripts/cron.scm
@@ -1,6 +1,7 @@
;;;; cron -- daemon for running jobs at scheduled times
;;; Copyright © 2003, 2012 Dale Mellor <dale_mellor@users.sourceforge.net>
;;; Copyright © 2015, 2016, 2018 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Mcron.
;;;
@@ -40,7 +41,9 @@ reading all the information in the users' crontabs and in
/etc/crontab.
-h, --help Display this help message
-sN, --schedule[=]N Display the next N jobs that will be run by cron
-n, --noetc Do not check /etc/crontab for updates (HIGHLY
- RECOMMENDED).")
+ RECOMMENDED).
+ --log-format=FMT (ice-9 format) format string for log messages
+ --date-format=FMT (srfi srfi-19) date format string for log
messages")
(newline)
(show-package-information))
@@ -49,6 +52,8 @@ reading all the information in the users' crontabs and in
/etc/crontab.
(define %options `((schedule (single-char #\s) (value #t)
(predicate ,string->number))
(noetc (single-char #\n) (value #f))
+ (log-format (value #t) (predicate ,validate-log-format))
+ (date-format (value #t) (predicate ,validate-date-format))
(version (single-char #\v) (value #f))
(help (single-char #\h) (value #f))))
@@ -142,31 +147,34 @@ option.\n")
;;;
(define* (main #:optional (args (command-line)))
- (let ((opts (getopt-long args %options)))
- (when config-debug
- (debug-enable 'backtrace))
- (cond ((option-ref opts 'help #f)
- (show-help)
- (exit 0))
- ((option-ref opts 'version #f)
- (show-version "cron")
- (exit 0))
- ((not (zero? (getuid)))
- (mcron-error 16
- "This program must be run by the root user (and should"
- " have been installed as such)."))
- ((access? config-pid-file F_OK)
- (mcron-error 1
- "A cron daemon is already running.\n (If you are sure"
- " this is not true, remove the file\n "
- config-pid-file ".)"))
- (else
- (%process-files (option-ref opts 'schedule #f)
- (option-ref opts 'noetc #f))
- (cond ((option-ref opts 'schedule #f)
- => (λ (count)
- (display-schedule (max 1 (string->number count)))
- (exit 0)))))))
+
+ (define opts (getopt-long args %options))
+
+ (when config-debug
+ (debug-enable 'backtrace))
+
+ (cond ((option-ref opts 'help #f)
+ (show-help)
+ (exit 0))
+ ((option-ref opts 'version #f)
+ (show-version "cron")
+ (exit 0))
+ ((not (zero? (getuid)))
+ (mcron-error 16
+ "This program must be run by the root user (and should"
+ " have been installed as such)."))
+ ((access? config-pid-file F_OK)
+ (mcron-error 1
+ "A cron daemon is already running.\n (If you are sure"
+ " this is not true, remove the file\n "
+ config-pid-file ".)"))
+ (else
+ (%process-files (option-ref opts 'schedule #f)
+ (option-ref opts 'noetc #f))
+ (cond ((option-ref opts 'schedule #f)
+ => (λ (count)
+ (display-schedule (max 1 (string->number count)))
+ (exit 0))))))
;; Daemonize ourself.
(unless (eq? 0 (primitive-fork)) (exit 0))
@@ -187,11 +195,12 @@ option.\n")
(with-output-to-file config-pid-file
(λ () (display (getpid)) (newline)))
- ;; Forever execute the 'run-job-loop', and when it drops out (can
- ;; only be because a message has come in on the socket) we
- ;; process the socket request before restarting the loop again.
- (catch-mcron-error
- (let ((fdes-list (cron-file-descriptors)))
- (while #t
- (run-job-loop fdes-list)
- (unless (null? fdes-list) (process-update-request fdes-list))))))
+ (parameterize ((%log-format (option-ref opts 'log-format (%log-format)))
+ (%date-format (option-ref opts 'date-format (%date-format))))
+ ;; Forever execute the 'run-job-loop', and when it drops out (can
+ ;; only be because a message has come in on the socket) we
+ ;; process the socket request before restarting the loop again.
+ (let ((fdes-list (cron-file-descriptors)))
+ (while #t
+ (run-job-loop fdes-list)
+ (unless (null? fdes-list) (process-update-request fdes-list))))))
diff --git a/src/mcron/scripts/mcron.scm b/src/mcron/scripts/mcron.scm
index 4c5f7b5..da5e079 100644
--- a/src/mcron/scripts/mcron.scm
+++ b/src/mcron/scripts/mcron.scm
@@ -1,6 +1,7 @@
;;;; mcron -- run jobs at scheduled times
;;; Copyright © 2003, 2012 Dale Mellor <dale_mellor@users.sourceforge.net>
;;; Copyright © 2015, 2016, 2018 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Mcron.
;;;
@@ -41,6 +42,8 @@ standard input), or use all the files in ~/.config/cron (or
the deprecated
-i, --stdin=(guile|vixie) Format of data passed as standard input
(default guile)
-s, --schedule[=N] Display the next N (or 8) jobs that will be run
+ --log-format=FMT (ice-9 format) format string for log messages
+ --date-format=FMT (srfi srfi-19) date format string for log messages
-?, --help Give this help list
-V, --version Print program version
@@ -118,6 +121,8 @@ $XDG_CONFIG_HOME is not defined uses ~/.config/cron
instead)."
(string=? in "vixie")))))
(schedule (single-char #\s) (value optional)
(predicate ,string->number))
+ (log-format (value #t) (predicate ,validate-log-format))
+ (date-format (value #t) (predicate ,validate-date-format))
(help (single-char #\?))
(version (single-char #\V))))))
@@ -140,14 +145,7 @@ $XDG_CONFIG_HOME is not defined uses ~/.config/cron
instead)."
((0) (setsid))
(else (exit 0)))))
- ;; Forever execute the 'run-job-loop', and when it drops out (can only be
- ;; because a message has come in on the socket) we process the socket
- ;; request before restarting the loop again.
- (catch-mcron-error
- (let ((fdes-list '()))
- (while #t
- (run-job-loop fdes-list)
- ;; we can also drop out of run-job-loop because of a SIGCHLD,
- ;; so must test FDES-LIST.
- (unless (null? fdes-list)
- (process-update-request fdes-list)))))))
+ (parameterize
+ ((%log-format (option-ref options 'log-format (%log-format)))
+ (%date-format (option-ref options 'date-format (%date-format))))
+ (run-job-loop))))
diff --git a/tests/base.scm b/tests/base.scm
index eb9e11a..914b4c6 100644
--- a/tests/base.scm
+++ b/tests/base.scm
@@ -1,5 +1,6 @@
;;;; base.scm -- tests for (mcron base) module
;;; Copyright © 2018 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Mcron.
;;;
@@ -16,7 +17,8 @@
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
-(use-modules (srfi srfi-64)
+(use-modules ((rnrs base) #:select (assert))
+ (srfi srfi-64)
(srfi srfi-111)
(mcron base))
@@ -40,7 +42,7 @@
#:key
(user (getpw))
(time-proc 1+)
- (action (λ () "dummy action"))
+ (action (lambda () "dummy action"))
(environment '())
(next-time 0))
(make-job user time-proc action environment displayable next-time))
@@ -191,25 +193,101 @@
;;; Check 'run-job' and 'child-cleanup'.
;;; XXX: Having to use the filesystem for a unit test is wrong.
(let* ((filename (tmpnam))
- (action (λ () (close-port (open-output-file filename))))
+ (action (lambda () (close-port (open-output-file filename))))
(job (make-dummy-job #:user (getpw (getuid)) #:action action)))
(dynamic-wind
(const #t)
- (λ ()
+ (lambda ()
(sigaction SIGCHLD (const #t))
- (run-job job)
- ;; Wait for the SIGCHLD signal sent when job exits.
- (pause)
- ;; Check 'run-job' result and if the number of children is up-to-date.
- (test-equal "run-job: basic"
- 1
- (and (access? filename F_OK)
- (unbox number-children)))
- (child-cleanup)
+ (let ((child-data (run-job job)))
+ ;; Wait for the SIGCHLD signal sent when job exits.
+ (pause)
+ ;; Check 'run-job' result and if the number of children is up-to-date.
+ (test-equal "run-job: basic"
+ 1
+ (and (access? filename F_OK)
+ (unbox number-children)))
+ (child-cleanup (list child-data)))
;; Check that 'child-cleanup' updates the number of children.
(test-equal "child-cleanup: one" 0 (unbox number-children)))
- (λ ()
+ (lambda ()
(and (access? filename F_OK) (delete-file filename))
(sigaction SIGCHLD SIG_DFL))))
+(define (dummy-job/capture-output action)
+ "Return the output of a dummy-job that ran ACTION."
+ (with-output-to-string
+ (lambda ()
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (sigaction SIGCHLD (const #t))
+ (let ((child-data
+ (run-job
+ (make-dummy-job
+ #:user (getpw (getuid))
+ #:action action))))
+ (pause)
+ (child-cleanup (list child-data))))
+ (lambda ()
+ #t
+ (sigaction SIGCHLD SIG_DFL))))))
+
+(test-assert "run-job, output"
+ (let ((output (dummy-job/capture-output
+ (lambda ()
+ (format #t "output line 1~%")
+ (format #t "output line 2\nand 3~%")
+ (system "echo poutine")
+ (format (current-error-port)
+ "some error~%")))))
+ (assert (string-contains output "dummy: running"))
+ (assert (string-contains output "dummy: output line 1"))
+ (assert (string-contains output "dummy: and 3"))
+ (assert (string-contains output "dummy: poutine"))
+ (assert (string-contains output "dummy: some error"))
+ (assert (string-contains output "dummy: completed in"))))
+
+(test-assert "validate-date-format, valid"
+ (validate-date-format "~1"))
+
+(test-assert "validate-date-format, invalid"
+ (catch 'mcron-error
+ (lambda ()
+ (validate-date-format "~¾")
+ #f)
+ (const #t)))
+
+(test-assert "validate-log-format, valid"
+ (validate-log-format "the message only: ~3@*~a~%"))
+
+(test-assert "validate-log-format, invalid"
+ (catch 'mcron-error
+ (lambda ()
+ ;; There aren't that many arguments!
+ (validate-log-format "~20@*~a~%")
+ #f)
+ (const #t)))
+
+(test-assert "run-job, output with custom format"
+ (let ((output (parameterize ((%log-format "the message only: ~3@*~a~%"))
+ (dummy-job/capture-output
+ (lambda ()
+ (format #t "output line 1~%"))))))
+ (string-contains output "the message only: output line 1\n")))
+
+(test-assert "run-job, failure"
+ (let ((output (dummy-job/capture-output
+ (lambda ()
+ (error "that didn't go well")))))
+ (assert (string-contains output "that didn't go well"))
+ (assert (string-contains output "failed after"))))
+
+(test-assert "run-job, failure in shell action"
+ (let ((output (dummy-job/capture-output
+ (lambda ()
+ (system "exit 1")))))
+ (assert (string-contains output "unclean exit status"))
+ (assert (string-contains output "failed after"))))
+
(test-end)
diff --git a/tests/basic.sh b/tests/basic.sh
index 7b2ca55..79b2032 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -1,5 +1,6 @@
# basic.sh -- basic tests for mcron
# Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
+# Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
#
# This file is part of GNU Mcron.
#
@@ -33,4 +34,16 @@ grep -e "foo" "output$$" || fail_ "'foo.guile' job is not
scheduled"
mcron --schedule=1 > "output$$"
grep -e "foo" "output$$" || fail_ "'foo.guile' job is not scheduled"
+mcron --date-format="~½" cron/foo.guile \
+ && fail_ "mcron --date-format unexpected pass"
+
+mcron --log-format="~½" cron/foo.guile \
+ && fail_ "mcron --log-format unexpected pass"
+
+cron --date-format="~½" cron/foo.guile \
+ && fail_ "cron --date-format unexpected pass"
+
+cron --log-format="~½" cron/foo.guile \
+ && fail_ "cron --log-format unexpected pass"
+
Exit 0
--
2.32.0
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [PATCH] base: Annotate output with job information.,
Maxim Cournoyer <=