diff options
Diffstat (limited to 'src/mcron')
| -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 |
3 files changed, 322 insertions, 103 deletions
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)))) |