diff options
| -rw-r--r-- | doc/mcron.texi | 84 | ||||
| -rw-r--r-- | src/cron.in | 3 | ||||
| -rw-r--r-- | src/mcron.in | 5 | ||||
| -rw-r--r-- | src/mcron/base.scm | 328 | ||||
| -rw-r--r-- | src/mcron/scripts/cron.scm | 77 | ||||
| -rw-r--r-- | src/mcron/scripts/mcron.scm | 20 | ||||
| -rw-r--r-- | tests/base.scm | 106 | ||||
| -rw-r--r-- | tests/basic.sh | 13 |
8 files changed, 516 insertions, 120 deletions
diff --git a/doc/mcron.texi b/doc/mcron.texi index a176b2e..efc7d36 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, 2022 Dale Mellor Copyright @copyright{} 2018 Mathieu Lirzin +Copyright @copyright{} 2021 Maxim Cournoyer @quotation Permission is granted to copy, distribute and/or modify this @@ -887,6 +888,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 @@ -981,6 +1029,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 @@ -1266,6 +1320,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..6e325f7 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,29 @@ ;;;; Code: (define-module (mcron base) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 control) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 suspendable-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 @@ -45,6 +57,8 @@ #:re-export (clear-environment-mods append-environment-mods)) +(install-suspendable-ports!) + ;; A cron job. (define-record-type <job> (make-job user time-proc action environment displayable next-time) @@ -71,6 +85,48 @@ (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 continuation name) + job-data? + (pid job-data:pid) ;string : the job process PID + (port job-data:port) ;port : an input + (continuation job-data:continuation ;a partial continuation to read port + set-job-data-continuation!) + (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,50 +228,185 @@ 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))))) + + ;; Create a pipe, and set its read side to non-blocking mode. + (define child->parent-pipe (pipe)) + (let ((flags (fcntl (car child->parent-pipe) F_GETFL))) + (fcntl (car child->parent-pipe) F_SETFL (logior O_NONBLOCK flags))) + + ;; 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)) + + ;; Use line buffering so the output is printed in "real time". + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (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...~%") + (flush-all-ports) + (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)) + (flush-all-ports) + (primitive-exit 0)) + (lambda args + (format (current-error-port) "failed after ~,3fs with: ~a~%" + (seconds-since start) args) + (flush-all-ports) + (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 ;pid + (car child->parent-pipe) ;port + #f ;continuation for a suspended port + (job:displayable job))))) ;name + +(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 upon reading the EOF character. As a side +effect, save the partial continuation of any suspended port to their +associated <job-data> instance." + (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) + + (define (log-data data) + ;; Print the lines as they become available. Do not block when a line + ;; could not be read. + (let ((name (job-data:name data)) + (pid (job-data:pid data)) + (port (job-data:port data))) + + (define (read-line*) + ;; Return, as a pair, the line and the terminated delimiter or end-of-file + ;; object. When a line cannot be read, return the '(suspended + ;; . partial-continuation) pair, where partial-continuation can be + ;; evaluated in the future when the port is ready to be read. + (call-with-prompt 'continue + (lambda () + (parameterize ((current-read-waiter + (lambda (_) + (abort-to-prompt 'continue)))) + (let ((cont (job-data:continuation data))) + (if cont + (begin + (set-job-data-continuation! data #f) ;reset continuation + (cont)) + ;; Also use the carriage return as a line delimiter to + ;; preserve the full output in a readable way. + (read-delimited "\n\r" port 'split))))) + (lambda (partial-continuation) + (cons 'suspended partial-continuation)))) + + (define (format-line line) + (format #t "~@?" (%log-format) timestamp pid name line)) + + (let loop ((line+delim (read-line*))) + (match line+delim + (('suspended . partial-continuation) + (set-job-data-continuation! data partial-continuation)) + ((line . (? eof-object?)) + (close port) + (unless (eof-object? line) + (format-line line))) + (("" . #\cr) + ;; A carriage return directly followed a delimiter. Ignore it. + (loop (read-line*))) + ((line . _) + (format-line line) + (loop (read-line*))))))) + + (for-each log-data + (remove (compose 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 @@ -236,23 +427,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 a6b1fa2..300aad0 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 @@ -119,6 +122,8 @@ directory. Double-check the folder and file permissions and syntax.")))) (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)))))) @@ -141,14 +146,7 @@ directory. Double-check the folder and file permissions and syntax.")))) ((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 |