diff options
Diffstat (limited to 'scm/mcron')
| -rw-r--r-- | scm/mcron/config.scm.in | 4 | ||||
| -rw-r--r-- | scm/mcron/crontab.scm | 4 | ||||
| -rw-r--r-- | scm/mcron/environment.scm | 55 | ||||
| -rw-r--r-- | scm/mcron/job-specifier.scm | 21 | ||||
| -rw-r--r-- | scm/mcron/main.scm | 673 | ||||
| -rw-r--r-- | scm/mcron/makefile.am | 65 | ||||
| -rw-r--r-- | scm/mcron/mcron-core.scm | 96 | ||||
| -rw-r--r-- | scm/mcron/redirect.scm | 1 | ||||
| -rw-r--r-- | scm/mcron/vixie-specification.scm | 14 |
9 files changed, 472 insertions, 461 deletions
diff --git a/scm/mcron/config.scm.in b/scm/mcron/config.scm.in index db2bc32..6a0a85d 100644 --- a/scm/mcron/config.scm.in +++ b/scm/mcron/config.scm.in @@ -1,6 +1,5 @@ ;; -*-scheme-*- -;; Copyright (C) 2015 Mathieu Lirzin ;; Copyright (C) 2003 Dale Mellor ;; ;; This file is part of GNU mcron. @@ -24,11 +23,8 @@ (define-module (mcron config)) (define-public config-debug @CONFIG_DEBUG@) -(define-public config-package-name "@PACKAGE_NAME@") -(define-public config-package-version "@PACKAGE_VERSION@") (define-public config-package-string "@PACKAGE_STRING@") (define-public config-package-bugreport "@PACKAGE_BUGREPORT@") -(define-public config-package-url "@PACKAGE_URL@") (define-public config-sendmail "@SENDMAIL@") (define-public config-spool-dir "@CONFIG_SPOOL_DIR@") diff --git a/scm/mcron/crontab.scm b/scm/mcron/crontab.scm index 6be5c61..30e5592 100644 --- a/scm/mcron/crontab.scm +++ b/scm/mcron/crontab.scm @@ -221,8 +221,8 @@ ;; The user is being silly. The message here is identical to the one Vixie cron ;; used to put out, for total compatibility. - (else (mcron-error 15 - "usage error: file name must be specified for replace."))) + (else + (mcron-error 15 "usage error: file name must be specified for replace."))) )) ;; End of file-level let-scopes. diff --git a/scm/mcron/environment.scm b/scm/mcron/environment.scm index f364a38..9f694f1 100644 --- a/scm/mcron/environment.scm +++ b/scm/mcron/environment.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 2003, 2015 Dale Mellor +;; Copyright (C) 2003 Dale Mellor ;; ;; This file is part of GNU mcron. ;; @@ -31,12 +31,42 @@ (define-module (mcron environment) - #:use-module (srfi srfi-26) #:export (modify-environment clear-environment-mods append-environment-mods get-current-environment-mods-copy)) + + + +;; The env-alist is an association list of variable names and values. Variables +;; later in the list will take precedence over variables before. We return a +;; fixed-up version in which some variables are given specific default values +;; (which the user can override), and two variables which the user is not +;; allowed to control are added at the end of the list. + +(define (impose-default-environment env-alist passwd-entry) + (append `(("HOME" . ,(passwd:dir passwd-entry)) + ("CWD" . ,(passwd:dir passwd-entry)) + ("SHELL" . ,(passwd:shell passwd-entry)) + ("TERM" . #f) + ("TERMCAP" . #f)) + env-alist + `(("LOGNAME" . ,(passwd:name passwd-entry)) + ("USER" . ,(passwd:name passwd-entry))))) + + + + +;; Modify the UNIX environment for the current process according to the given +;; association list of variables, with the default variable values imposed. + +(define (modify-environment env-alist passwd-entry) + (for-each (lambda (variable) + (setenv (car variable) (cdr variable))) + (impose-default-environment env-alist passwd-entry))) + + ;; As we parse configuration files, we build up an alist of environment @@ -73,24 +103,3 @@ (set! current-environment-mods (append current-environment-mods (list (cons name value)))) #t) - - - -;; Modify the UNIX environment for the current process according to the given -;; association list of variables, with the default variable values imposed. - -(define (modify-environment env-alist passwd-entry) - (for-each (lambda (a) (setenv (car a) (cdr a))) - (let ((home-dir (passwd:dir passwd-entry)) - (user-name (passwd:name passwd-entry))) - (append - ;; Default environment variables which can be overidden by ENV. - `(("HOME" . ,home-dir) - ("CWD" . ,home-dir) - ("SHELL" . ,(passwd:shell passwd-entry)) - ("TERM" . #f) - ("TERMCAP" . #f)) - env-alist - ;; Environment variables with imposed values. - `(("LOGNAME" . ,user-name) - ("USER" . ,user-name)))))) diff --git a/scm/mcron/job-specifier.scm b/scm/mcron/job-specifier.scm index 7ed912b..cce948c 100644 --- a/scm/mcron/job-specifier.scm +++ b/scm/mcron/job-specifier.scm @@ -34,7 +34,7 @@ set-configuration-time job find-best-next) - #:use-module (mcron mcron-core) + #:use-module (mcron core) #:use-module (mcron environment) #:use-module (mcron vixie-time) #:re-export (append-environment-mods)) @@ -203,16 +203,11 @@ (define configuration-user (getpw (getuid))) (define configuration-time (current-time)) - - (define (set-configuration-user user) (set! configuration-user (if (or (string? user) (integer? user)) (getpw user) user))) - - - (define (set-configuration-time time) (set! configuration-time time)) @@ -238,9 +233,10 @@ ((list? action) (lambda () (primitive-eval action))) ((string? action) (lambda () (system action))) (else - (throw 'mcron-error 2 - "job: invalid second argument (action; should be lambda " - "function, string or list)")))) + (throw 'mcron-error + 2 + "job: invalid second argument (action; should be lambda" + " function, string or list)")))) (time-proc (cond ((procedure? time-proc) time-proc) @@ -248,9 +244,10 @@ ((list? time-proc) (lambda (current-time) (primitive-eval time-proc))) (else - (throw 'mcron-error 3 - "job: invalid first argument (next-time-function; " - "should be function, string or list)")))) + (throw 'mcron-error + 3 + "job: invalid first argument (next-time-function; should ") + "be function, string or list)"))) (displayable (cond ((not (null? displayable)) (car displayable)) ((procedure? action) "Lambda function") diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index dc839cc..36adef9 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 2003, 2012, 2015 Dale Mellor +;; Copyright (C) 2003, 2012 Dale Mellor ;; ;; This file is part of GNU mcron. ;; @@ -16,24 +16,34 @@ ;; with GNU mcron. If not, see <http://www.gnu.org/licenses/>. -(define-module (mcron main) - #:use-module (ice-9 getopt-long) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 regex) - #:use-module (mcron config) - #:use-module (mcron mcron-core) - #:use-module (mcron job-specifier) - #:use-module (mcron vixie-specification) - #:use-module (srfi srfi-2) - #:use-module (srfi srfi-26) - #:export (delete-run-file - main)) + +;; This is the 'main' routine for the whole system; the top of this file is the +;; global entry point (after the minimal C wrapper, mcron.c.template); to all +;; intents and purposes the program is pure Guile and starts here. +;; +;; This file is built into mcron.c.template by the makefile, which stringifies +;; the whole lot, and escapes quotation marks and escape characters +;; accordingly. Bear this in mind when considering literal multi-line strings. +;; +;; (l0ad "crontab.scm") (sic) is inlined by the makefile. All other +;; functionality comes through modules in .../share/guile/site/mcron/*.scm. + + + +;; Pull in some constants set by the builder (via autoconf) at configuration +;; time. Turn debugging on if indicated. + +(use-modules (mcron config)) +(if config-debug (begin (debug-enable 'debug) + (debug-enable 'backtrace))) -;; Extract the actual command name from \a command. This returns the last -;; part of \a command without any non-alphabetic characters. For example -;; "in.cron" and "./mcron" will return respectively "cron" and "mcron". +;; To determine the name of the program, scan the first item of the command line +;; backwards for the first non-alphabetic character. This allows names like +;; in.cron to be accepted as an invocation of the cron command. + +(use-modules (ice-9 regex) (ice-9 rdelim)) (define command-name (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") (car (command-line))))) @@ -41,49 +51,49 @@ ;; Code contributed by Sergey Poznyakoff. Print an error message (made up from -;; the parts of \a rest), and if the \a exit-code error is fatal (present and -;; non-zero) then exit to the system with \a exit-code. +;; the parts of rest), and if the error is fatal (present and non-zero) then +;; exit to the system with this code. (define (mcron-error exit-code . rest) (with-output-to-port (current-error-port) (lambda () - (for-each display - (cons* command-name ": " rest)) + (for-each display (append (list command-name ": ") rest)) (newline))) - (when (and exit-code - (not (eq? exit-code 0))) - (primitive-exit exit-code))) + (if (and exit-code (not (eq? exit-code 0))) + (primitive-exit exit-code))) -;; Code contributed by Sergey Poznyakoff and improved upon by Mathieu Lirzin -;; with newer guile features. Execute the expressions. If an 'mcron-error +;; Code contributed by Sergey Poznyakoff. Execute body. If an 'mcron-error ;; exception occurs, print its diagnostics and exit with its error code. -(define-syntax-rule (catch-mcron-error exp ...) - (catch 'mcron-error - (lambda () exp ...) - (lambda (key exit-code . msg) - (apply mcron-error exit-code msg)))) +(defmacro catch-mcron-error (. body) + `(catch 'mcron-error + (lambda () + ,@body) + (lambda (key exit-code . msg) + (apply mcron-error exit-code msg)))) -;; One of the symbols \c mcron, \c crond or \c crontab according to the means -;; of our invocation. +;; We will be doing a lot of testing of the command name, so it makes sense to +;; perform the string comparisons once and for all here. -(define command-type - (let ((command=? (cute string=? command-name <>))) - (cond ((command=? "mcron") 'mcron) - ((or (command=? "cron") (command=? "crond")) 'cron) - ((command=? "crontab") 'crontab) - (else (mcron-error 12 "The command name is invalid."))))) +(define command-type (cond ((string=? command-name "mcron") 'mcron) + ((or (string=? command-name "cron") + (string=? command-name "crond")) 'cron) + ((string=? command-name "crontab") 'crontab) + (else + (mcron-error 12 "The command name is invalid.")))) -;; There are a different set of options for the crontab personality compared -;; to all the others, with the --help and --version options common to all the +;; There are a different set of options for the crontab personality compared to +;; all the others, with the --help and --version options common to all the ;; personalities. +(use-modules (ice-9 getopt-long)) + (define options (catch 'misc-error @@ -110,96 +120,129 @@ '((version (single-char #\v) (value #f)) (help (single-char #\h) (value #f)))))) (lambda (key func fmt args . rest) - (mcron-error 1 (apply format (cons* #f fmt args)))))) - - + (mcron-error 1 (apply format (append (list #f fmt) args)))))) + +;; If the user asked for the version of this program, give it to him and get +;; out. + +(if (option-ref options 'version #f) + (begin + (display (string-append "\n +" command-name " (" config-package-string ")\n +Written by Dale Mellor\n +\n +Copyright (C) 2003, 2006, 2014 Dale Mellor\n +This is free software; see the source for copying conditions. There is NO\n +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n +")) + (quit))) + + + +;; Likewise if the user requested the help text. + +(if (option-ref options 'help #f) + (begin + (display (string-append " +Usage: " (car (command-line)) +(case command-type + + ((mcron) +" [OPTIONS] [FILES]\n +Run an mcron process according to the specifications in the FILES (`-' for\n +standard input), or use all the files in ~/.config/cron (or the \n +deprecated ~/.cron) with .guile or .vixie extensions.\n +\n + -v, --version Display version\n + -h, --help Display this help message\n + -sN, --schedule[=]N Display the next N jobs that will be run by mcron\n + -d, --daemon Immediately detach the program from the terminal\n + and run as a daemon process\n + -i, --stdin=(guile|vixie) Format of data passed as standard input or\n + file arguments (default guile)") -;; Display version information for \a command and quit. + ((cron) +" [OPTIONS]\n +Unless an option is specified, run a cron daemon as a detached process, \n +reading all the information in the users' crontabs and in /etc/crontab.\n +\n + -v, --version Display version\n + -h, --help Display this help message\n + -sN, --schedule[=]N Display the next N jobs that will be run by cron\n + -n, --noetc Do not check /etc/crontab for updates (HIGHLY\n + RECOMMENDED).") + + ((crontab) + (string-append " [-u user] file\n" + " " (car (command-line)) " [-u user] { -e | -l | -r }\n" + " (default operation is replace, per 1003.2)\n" + " -e (edit user's crontab)\n" + " -l (list user's crontab)\n" + " -r (delete user's crontab)\n")) -(define* (show-version #:optional (command command-name)) - (let* ((name config-package-name) - (short-name (cadr (string-split name #\space))) - (version config-package-version)) - (simple-format #t "~a (~a) ~a -Copyright (C) 2015 Free Software Foundation, Inc. + (else "rubbish")) -License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> -This is free software: you are free to change and redistribute it. -There is NO WARRANTY, to the extent permitted by law.\n" - command name version) - (quit))) +"\n\n +Report bugs to " config-package-bugreport ".\n +")) + (quit))) -;; Display where to get help and send bug reports. +;; This is called from the C front-end whenever a terminal signal is +;; received. We remove the /var/run/cron.pid file so that crontab and other +;; invocations of cron don't get the wrong idea that a daemon is currently +;; running. -(define (show-package-information) - (simple-format #t "\nReport bugs to: ~a. -~a home page: <~a> -General help using GNU software: <http://www.gnu.org/gethelp/>\n" - config-package-bugreport - config-package-name - config-package-url)) +(define (delete-run-file) + (catch #t (lambda () (delete-file config-pid-file) + (delete-file config-socket-file)) + noop) + (quit)) -;; Display usage information and quit. +;; Setup the cron process, if appropriate. If there is already a +;; /var/run/cron.pid file, then we must assume a cron daemon is already running +;; and refuse to start another one. +;; +;; Otherwise, clear the MAILTO environment variable so that output from cron +;; jobs is sent to the various users (this may still be overridden in the +;; configuration files), and call the function in the C wrapper to set up +;; terminal signal responses to vector to the procedure above. The PID file will +;; be filled in properly later when we have forked our daemon process (but not +;; done if we are only viewing the schedules). -(define (show-help) - (simple-format #t "Usage: ~a" command-name) - (display - (case command-type - ((mcron) - " [OPTIONS] [FILES] -Run an mcron process according to the specifications in the FILES (`-' for -standard input), or use all the files in ~/.config/cron (or the -deprecated ~/.cron) with .guile or .vixie extensions. +(if (eq? command-type 'cron) + (begin + (if (not (eqv? (getuid) 0)) + (mcron-error 16 + "This program must be run by the root user (and should " + "have been installed as such).")) + (if (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 + ".)")) + (if (not (option-ref options 'schedule #f)) + (with-output-to-file config-pid-file noop)) + (setenv "MAILTO" #f) + (c-set-cron-signals))) - -v, --version Display version - -h, --help Display this help message - -sN, --schedule[=]N Display the next N jobs that will be run by mcron - -d, --daemon Immediately detach the program from the terminal - and run as a daemon process - -i, --stdin=(guile|vixie) Format of data passed as standard input or - file arguments (default guile)") - ((cron) - " [OPTIONS] -Unless an option is specified, run a cron daemon as a detached process, -reading all the information in the users' crontabs and in /etc/crontab. - - -v, --version Display version - -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).") - ((crontab) - " [-u user] file - crontab [-u user] { -e | -l | -r } - (default operation is replace, per 1003.2) - -e (edit user's crontab) - -l (list user's crontab) - -r (delete user's crontab)") - (else "\nrubbish"))) - (newline) - (show-package-information) - (quit)) +;; Define the functions available to the configuration files. While we're here, +;; we'll get the core loaded as well. -;; Remove the /var/run/cron.pid file so that crontab and other invocations of -;; cron don't get the wrong idea that a daemon is currently running. This -;; procedure is called from the C front-end whenever a terminal signal is -;; received. +(use-modules (mcron core) + (mcron job-specifier) + (mcron vixie-specification)) -(define (delete-run-file) - (catch #t (lambda () (delete-file config-pid-file) - (delete-file config-socket-file)) - noop) - (quit)) - -;; Return standard input as a string. +;; Procedure to slurp the standard input into a string. (define (stdin->string) (with-output-to-string (lambda () (do ((in (read-char) (read-char))) @@ -208,83 +251,183 @@ reading all the information in the users' crontabs and in /etc/crontab. -;; Return a thunk which process each file in \a directory with \a proc. The -;; \a directory must be a directory name. The \a proc argument must be a -;; procedure that takes one file name argument. +;; Now we have the procedures in place for dealing with the contents of +;; configuration files, the crontab personality is able to validate such +;; files. If the user requested the crontab personality, we load and run the +;; code here and then get out. + +(if (eq? command-type 'crontab) + (begin + (load "crontab.scm") + (quit))) + + -(define (proc-in-directory directory proc) - (let ((dir (opendir directory))) - (do ((file-name (readdir dir) (readdir dir))) - ((eof-object? file-name) (closedir dir)) - (proc file-name)))) +;; Code contributed by Sergey Poznyakoff. Determine if the given file is a +;; regular file or not. +(define (regular-file? file) + (catch 'system-error + (lambda () + (eq? (stat:type (stat file)) 'regular)) + (lambda (key call fmt args . rest) + (mcron-error 0 (apply format (append (list #f fmt) args))) + #f))) -;; Process \a file-name according its extension. When \a guile-syntax? is \c -;; TRUE, force guile syntax usage. If \a file-name format is not recognized, -;; it is silently ignored (this deals properly with most editors' backup -;; files, for instance). -(define process-user-file - (let ((guile-regexp (make-regexp "\\.gui(le)?$")) - (vixie-regexp (make-regexp "\\.vix(ie)?$"))) - (lambda* (file-path #:optional assume-guile) - (cond ((string=? "-" file-path) - (if (string=? (option-ref options 'stdin "guile") "vixie") - (read-vixie-port (current-input-port)) - (eval-string (stdin->string)))) - ((regexp-exec vixie-regexp file-path) - (read-vixie-file file-path)) - ((or assume-guile - (regexp-exec guile-regexp file-path)) - (load file-path)))))) +;; Procedure which processes any configuration file according to the +;; extension. If a file is not recognized, it is silently ignored (this deals +;; properly with most editors' backup files, for instance). +(define guile-file-regexp (make-regexp "\\.gui(le)?$")) +(define vixie-file-regexp (make-regexp "\\.vix(ie)?$")) +(define (process-user-file file-path . assume-guile) + (cond ((string=? file-path "-") + (if (string=? (option-ref options 'stdin "guile") "vixie") + (read-vixie-port (current-input-port)) + (eval-string (stdin->string)))) + ((or (not (null? assume-guile)) + (regexp-exec guile-file-regexp file-path)) + (load file-path)) + ((regexp-exec vixie-file-regexp file-path) + (read-vixie-file file-path)))) -;; Process files in $XDG_CONFIG_HOME/cron and/or ~/.cron directories (if -;; $XDG_CONFIG_HOME is not defined uses ~/.config/cron instead). + + +;; Procedure to run through all the files in a user's ~/.cron and/or +;; $XDG_CONFIG_HOME/cron or ~/.config/cron directories (only happens under the +;; mcron personality). (define (process-files-in-user-directory) (let ((errors 0) (home-directory (passwd:dir (getpw (getuid))))) - (map (lambda (dir) - (catch #t - (lambda () - (proc-in-directory - dir - (lambda (file-name) - (process-user-file (string-append dir "/" file-name))))) - (lambda (key . args) - (set! errors (1+ errors))))) - (list (string-append home-directory "/.cron") - (string-append (or (getenv "XDG_CONFIG_HOME") - (string-append home-directory "/.config")) - "/cron"))) - (when (eq? 2 errors) - (mcron-error 13 - "Cannot read files in your ~/.config/cron (or ~/.cron) directory.")))) - - - -;; Process all the files in the crontab directory. When the job procedure is -;; run on behalf of the configuration files, the jobs are registered on the -;; system with the appropriate user. Only root should be able to perform this -;; operation. The permissions on the /var/cron/tabs directory enforce this. + (map (lambda (config-directory) + (catch #t + (lambda () + (let ((directory (opendir config-directory))) + (do ((file-name (readdir directory) (readdir directory))) + ((eof-object? file-name) (closedir directory)) + (process-user-file (string-append config-directory + "/" + file-name))))) + (lambda (key . args) + (set! errors (1+ errors))))) + (list (string-append home-directory "/.cron") + (string-append (or (getenv "XDG_CONFIG_HOME") + (string-append home-directory "/.config")) + "/cron"))) + (if (eq? 2 errors) + (mcron-error 13 + "Cannot read files in your ~/.config/cron (or ~/.cron) " + "directory.")))) + + + +;; Procedure to check that a user name is in the passwd database (it may happen +;; that a user is removed after creating a crontab). If the user name is valid, +;; the full passwd entry for that user is returned to the caller. + +(define (valid-user user-name) + (setpwent) + (do ((entry (getpw) (getpw))) + ((or (not entry) + (string=? (passwd:name entry) user-name)) + (endpwent) + entry))) + + + +;; Procedure to process all the files in the crontab directory, making sure that +;; each file is for a legitimate user and setting the configuration-user to that +;; user. In this way, when the job procedure is run on behalf of the +;; configuration files, the jobs are registered with the system with the +;; appropriate user. Note that only the root user should be able to perform this +;; operation, but we leave it to the permissions on the /var/cron/tabs directory +;; to enforce this. + +(use-modules (srfi srfi-2)) ;; For and-let*. (define (process-files-in-system-directory) (catch #t - (lambda () - (proc-in-directory - config-spool-dir - (lambda (user-name) - (and-let* ((user (false-if-exception (getpwnam user-name)))) - (set-configuration-user user) - (catch-mcron-error - (read-vixie-file - (string-append config-spool-dir "/" user-name))))))) - (lambda (key . args) - (mcron-error 4 - "You do not have permission to access the system crontabs.")))) + (lambda () + (let ((directory (opendir config-spool-dir))) + (do ((file-name (readdir directory) (readdir directory))) + ((eof-object? file-name)) + (and-let* ((user (valid-user file-name))) + (set-configuration-user user) ;; / ?? !!!! + (catch-mcron-error + (read-vixie-file (string-append config-spool-dir + "/" + file-name))))))) + (lambda (key . args) + (mcron-error + 4 + "You do not have permission to access the system crontabs.")))) + + + +;; Having defined all the necessary procedures for scanning various sets of +;; files, we perform the actual configuration of the program depending on the +;; personality we are running as. If it is mcron, we either scan the files +;; passed on the command line, or else all the ones in the user's .config/cron +;; (or .cron) directory. If we are running under the cron personality, we read +;; the /var/cron/tabs directory and also the /etc/crontab file. + +(case command-type + ((mcron) (if (null? (option-ref options '() '())) + (process-files-in-user-directory) + (for-each (lambda (file-path) + (process-user-file file-path #t)) + (option-ref options '() '())))) + + ((cron) (process-files-in-system-directory) + (use-system-job-list) + (catch-mcron-error + (read-vixie-file "/etc/crontab" parse-system-vixie-line)) + (use-user-job-list) + (if (not (option-ref options 'noetc #f)) + (begin + (display +"WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do\n +not use this file, or you are prepared to manually restart cron whenever you\n +make a change, then it is HIGHLY RECOMMENDED that you use the --noetc\n +option.\n") + (set-configuration-user "root") + (job '(- (next-minute-from (next-minute)) 6) + check-system-crontab + "/etc/crontab update checker."))))) + + + +;; If the user has requested a schedule of jobs that will run, we provide the +;; information here and then get out. +;; +;; Start by determining the number of time points in the future that output is +;; required for. This may be provided on the command line as a parameter to the +;; --schedule option, or else we assume a default of 8. Finally, ensure that the +;; count is some positive integer. + +(and-let* ((count (option-ref options 'schedule #f))) + (set! count (string->number count)) + (display (get-schedule (if (<= count 0) 1 count))) + (quit)) + + + +;; If we are supposed to run as a daemon process (either a --daemon option has +;; been explicitly used, or we are running as cron or crond), detach from the +;; terminal now. If we are running as cron, we can now write the PID file. + +(if (option-ref options 'daemon (eq? command-type 'cron)) + (begin + (if (not (eqv? (primitive-fork) 0)) + (quit)) + (setsid) + (if (eq? command-type 'cron) + (with-output-to-file config-pid-file + (lambda () (display (getpid)) (newline)))))) @@ -293,30 +436,32 @@ reading all the information in the users' crontabs and in /etc/crontab. ;; inform the main wait-run-wait execution loop to listen for incoming messages ;; on this socket. -(define (cron-file-descriptors) - (if (eq? command-type 'cron) - (catch #t - (lambda () - (let ((socket (socket AF_UNIX SOCK_STREAM 0))) - (bind socket AF_UNIX config-socket-file) - (listen socket 5) - (list socket))) - (lambda (key . args) - (delete-file config-pid-file) - (mcron-error 1 - "Cannot bind to UNIX socket " config-socket-file))) - '())) +(define fd-list '()) +(if (eq? command-type 'cron) + (catch #t + (lambda () + (let ((socket (socket AF_UNIX SOCK_STREAM 0))) + (bind socket AF_UNIX config-socket-file) + (listen socket 5) + (set! fd-list (list socket)))) + (lambda (key . args) + (delete-file config-pid-file) + (mcron-error 1 + "Cannot bind to UNIX socket " + config-socket-file)))) + -;; Read a user name from the socket, dealing with the /etc/crontab special + +;; This function is called whenever a message comes in on the above socket. We +;; read a user name from the socket, dealing with the "/etc/crontab" special ;; case, remove all the user's jobs from the job list, and then re-read the -;; user's updated file. In the special case drop all the system jobs and -;; re-read the /etc/crontab file. This function should be called whenever a -;; message comes in on the above socket. +;; user's updated file. In the special case we drop all the system jobs and +;; re-read the /etc/crontab file. -(define (process-update-request fd-list) - (let* ((socket (car (accept (car fd-list)))) +(define (process-update-request) + (let* ((socket (car (accept (car fd-list)))) (user-name (read-line socket))) (close socket) (set-configuration-time (current-time)) @@ -330,123 +475,29 @@ reading all the information in the users' crontabs and in /etc/crontab. (let ((user (getpw user-name))) (remove-user-jobs user) (set-configuration-user user) - (read-vixie-file - (string-append config-spool-dir "/" user-name))))))) + (read-vixie-file (string-append config-spool-dir "/" user-name))))))) -;; Entry point. -;; -;; This is the 'main' routine for the whole system; this module is the global -;; entry point (after the minimal C wrapper); to all intents and purposes the -;; program is pure Guile and starts here. - -(define (main . args) - ;; Added by Sergey Poznyakoff. This no-op will collect zombie child processes - ;; as soon as they die. This is a big improvement as previously they stayed - ;; around the system until the next time mcron wakes to fire a new job off. - (when config-debug - (debug-enable 'backtrace)) - (when (option-ref options 'version #f) - (show-version)) - (when (option-ref options 'help #f) - (show-help)) - - ;; Setup the cron process, if appropriate. If there is already a - ;; /var/run/cron.pid file, then we must assume a cron daemon is already - ;; running and refuse to start another one. - ;; - ;; Otherwise, clear the MAILTO environment variable so that output from cron - ;; jobs is sent to the various users (this may still be overridden in the - ;; configuration files), and call the function in the C wrapper to set up - ;; terminal signal responses to vector to the procedure above. The PID file - ;; will be filled in properly later when we have forked our daemon process - ;; (but not done if we are only viewing the schedules). - (when (eq? command-type 'cron) - (unless (eqv? (getuid) 0) - (mcron-error 16 - "This program must be run by the root user (and should have been " - "installed as such).")) - (when (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 ".)")) - (unless (option-ref options 'schedule #f) - (with-output-to-file config-pid-file noop)) - (setenv "MAILTO" #f) - ;; Mathieu Lirzin: At compile time, this yields a "possibly unbound - ;; variable" warning, but this is OK since it is bound in the C wrapper. - (c-set-cron-signals)) - - ;; Now we have the procedures in place for dealing with the contents of - ;; configuration files, the crontab personality is able to validate such - ;; files. If the user requested the crontab personality, we load and run the - ;; code here and then get out. - (when (eq? command-type 'crontab) - (load "crontab.scm") - (quit)) - - ;; Having defined all the necessary procedures for scanning various sets of - ;; files, we perform the actual configuration of the program depending on - ;; the personality we are running as. If it is mcron, we either scan the - ;; files passed on the command line, or else all the ones in the user's - ;; .config/cron (or .cron) directory. If we are running under the cron - ;; personality, we read the /var/cron/tabs directory and also the - ;; /etc/crontab file. - (case command-type - ((mcron) - (if (null? (option-ref options '() '())) - (process-files-in-user-directory) - (for-each (lambda (file-path) (process-user-file file-path - 'guile-syntax)) - (option-ref options '() '())))) - ((cron) - (process-files-in-system-directory) - (use-system-job-list) - (catch-mcron-error (read-vixie-file "/etc/crontab" - parse-system-vixie-line)) - (use-user-job-list) - (unless (option-ref options 'noetc #f) - (display "\ -WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do -not use this file, or you are prepared to manually restart cron whenever you -make a change, then it is HIGHLY RECOMMENDED that you use the --noetc -option.\n") - (set-configuration-user "root") - (job '(- (next-minute-from (next-minute)) 6) - check-system-crontab - "/etc/crontab update checker.")))) - - ;; If the user has requested a schedule of jobs that will run, we provide - ;; the information here and then get out. Start by determining the number - ;; of time points in the future that output is required for. This may be - ;; provided on the command line as a parameter to the --schedule option, or - ;; else we assume a default of 8. Finally, ensure that the count is some - ;; positive integer. - (and-let* ((count (option-ref options 'schedule #f))) - (set! count (string->number count)) - (display (get-schedule (max 1 count))) - (quit)) - - ;; If we are supposed to run as a daemon process (either a --daemon option - ;; has been explicitly used, or we are running as cron or crond), detach - ;; from the terminal now. If we are running as cron, we can now write the - ;; PID file. - (when (option-ref options 'daemon (eq? command-type 'cron)) - (unless (eqv? (primitive-fork) 0) - (quit)) - (setsid) - (when (eq? command-type 'cron) - (with-output-to-file config-pid-file - (lambda () (display (getpid)) (newline))))) - - ;; Now the main loop. Forever execute the run-job-loop procedure in the - ;; mcron core, 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. Sergey Poznyakoff: we can also drop out of run-job-loop - ;; because of a SIGCHLD, so must test fd-list. - (catch-mcron-error - (let ((fd-list (cron-file-descriptors))) - (while #t - (run-job-loop fd-list) - (unless (null? fd-list) - (process-update-request fd-list)))))) + +;; Added by Sergey Poznyakoff. This no-op will collect zombie child processes +;; as soon as they die. This is a big improvement as previously they stayed +;; around the system until the next time mcron wakes to fire a new job off. + +;; Unfortunately it seems to interact badly with the select system call, +;; wreaking havoc... + +;; (sigaction SIGCHLD (lambda (sig) noop) SA_RESTART) + + + +;; Now the main loop. Forever execute the run-job-loop procedure in the mcron +;; core, 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. +;; Sergey Poznyakoff: we can also drop out of run-job-loop because of a SIGCHLD, +;; so must test fd-list. + +(catch-mcron-error + (while #t + (run-job-loop fd-list) + (if (not (null? fd-list)) + (process-update-request)))) diff --git a/scm/mcron/makefile.am b/scm/mcron/makefile.am index e371311..931b03b 100644 --- a/scm/mcron/makefile.am +++ b/scm/mcron/makefile.am @@ -1,60 +1,15 @@ -## Makefile for the scm/mcron directory of mcron. +EXTRA_DIST = main.scm mcron-core.scm vixie-specification.scm \ + crontab.scm environment.scm job-specifier.scm redirect.scm \ + vixie-time.scm -# Copyright (C) 2015 Mathieu Lirzin -# -# This file is part of GNU mcron. -# -# GNU mcron is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, either version 3 of the License, or (at your option) any later -# version. -# -# GNU mcron is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -# A PARTICULAR PURPOSE. See the GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License along with -# GNU mcron. If not, see <http://www.gnu.org/licenses/>. +pkgdata_DATA = core.scm environment.scm job-specifier.scm redirect.scm \ + vixie-time.scm vixie-specification.scm config.scm -## Process this file with automake to produce makefile.in. +# If you're wondering, the configure script keeps deleting all files with a name +# like core.*, so we have to keep re-making it (I lost a good day's work because +# of this). -MODULES = environment.scm \ - job-specifier.scm \ - main.scm \ - mcron-core.scm \ - redirect.scm \ - vixie-specification.scm \ - vixie-time.scm +core.scm : mcron-core.scm + $(CP) mcron-core.scm core.scm -GOBJECTS = $(MODULES:%.scm=%.go) config.go - -nobase_dist_guilemodule_DATA = $(MODULES) crontab.scm -nobase_nodist_guilemodule_DATA = $(GOBJECTS) config.scm - -CLEANFILES = $(GOBJECTS) - -AM_V_GUILEC = $(AM_V_GUILEC_$(V)) -AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) -AM_V_GUILEC_0 = @echo " GUILEC" $@; - -# Unset 'GUILE_LOAD_COMPILED_PATH' altogether while compiling. Otherwise, if -# $GUILE_LOAD_COMPILED_PATH contains $(moduledir), we may find .go files in -# there that are newer than the local .scm files (for instance because the -# user ran 'make install' recently). When that happens, we end up loading -# those previously-installed .go files, which may be stale, thereby breaking -# the whole thing. -# -# XXX: Use the C locale for when Guile lacks -# <http://git.sv.gnu.org/cgit/guile.git/commit/?h=stable-2.0&id=e2c6bf3866d1186c60bacfbd4fe5037087ee5e3f>. -.scm.go: - $(AM_V_GUILEC)$(MKDIR_P) `dirname "$@"` ; \ - unset GUILE_LOAD_COMPILED_PATH ; \ - LC_ALL=C \ - $(GUILD) compile \ - -L "$(top_builddir)/scm" -L "$(top_srcdir)/scm" \ - -Wformat -Wunbound-variable -Warity-mismatch \ - --target="$(host)" \ - -o "$@" "$<" - -SUFFIXES = .go diff --git a/scm/mcron/mcron-core.scm b/scm/mcron/mcron-core.scm index 9b83faf..518bcac 100644 --- a/scm/mcron/mcron-core.scm +++ b/scm/mcron/mcron-core.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 2003, 2015 Dale Mellor +;; Copyright (C) 2003 Dale Mellor ;; ;; This file is part of GNU mcron. ;; @@ -17,9 +17,8 @@ -(define-module (mcron mcron-core) +(define-module (mcron core) #:use-module (mcron environment) - #:use-module (srfi srfi-9) #:export (add-job remove-user-jobs get-schedule @@ -39,7 +38,7 @@ ;; The list of all jobs known to the system. Each element of the list is ;; -;; (make-job user next-time-function action environment displayable next-time) +;; (vector user next-time-function action environment displayable next-time) ;; ;; where action must be a procedure, and the environment is an alist of ;; modifications that need making to the UNIX environment before the action is @@ -61,17 +60,18 @@ (define (use-system-job-list) (set! configuration-source 'system)) (define (use-user-job-list) (set! configuration-source 'user)) -;; A cron job. -(define-record-type <job> - (make-job user time-proc action environment displayable next-time) - job? - (user job:user) ;string : user passwd entry - (time-proc job:next-time-function) ;proc : with one 'time' parameter - (action job:action) ;thunk : user's code - (environment job:environment) ;alist : environment variables - (displayable job:displayable) ;string : visible in schedule - (next-time job:next-time ;number : time in UNIX format - job:next-time-set!)) + + +;; Convenience functions for getting and setting the elements of a job object. + +(define (job:user job) (vector-ref job 0)) +(define (job:next-time-function job) (vector-ref job 1)) +(define (job:action job) (vector-ref job 2)) +(define (job:environment job) (vector-ref job 3)) +(define (job:displayable job) (vector-ref job 4)) +(define (job:next-time job) (vector-ref job 5)) + + ;; Remove jobs from the user-job-list belonging to this user. @@ -97,12 +97,12 @@ (define (add-job time-proc action displayable configuration-time configuration-user) - (let ((entry (make-job configuration-user - time-proc - action - (get-current-environment-mods-copy) - displayable - (time-proc configuration-time)))) + (let ((entry (vector configuration-user + time-proc + action + (get-current-environment-mods-copy) + displayable + (time-proc configuration-time)))) (if (eq? configuration-source 'user) (set! user-job-list (cons entry user-job-list)) (set! system-job-list (cons entry system-job-list))))) @@ -165,17 +165,18 @@ (lambda () (do ((count count (- count 1))) ((eqv? count 0)) - (and-let* - ((next-jobs (find-next-jobs)) - (time (car next-jobs)) - (date-string (strftime "%c %z\n" (localtime time)))) - (for-each (lambda (job) - (display date-string) - (display (job:displayable job)) - (newline)(newline) - (job:next-time-set! job ((job:next-time-function job) - (job:next-time job)))) - (cdr next-jobs))))))) + (and-let* ((next-jobs (find-next-jobs)) + (time (car next-jobs)) + (date-string (strftime "%c %z\n" (localtime time)))) + (for-each (lambda (job) + (display date-string) + (display (job:displayable job)) + (newline)(newline) + (vector-set! job + 5 + ((job:next-time-function job) + (job:next-time job)))) + (cdr next-jobs))))))) @@ -194,21 +195,22 @@ ;; to run. (define (run-jobs jobs-list) - (for-each - (lambda (job) - (if (eqv? (primitive-fork) 0) - (begin - (setgid (passwd:gid (job:user job))) - (setuid (passwd:uid (job:user job))) - (chdir (passwd:dir (job:user job))) - (modify-environment (job:environment job) (job:user job)) - ((job:action job)) - (primitive-exit 0)) - (begin - (set! number-children (+ number-children 1)) - (job:next-time-set! job ((job:next-time-function job) - (current-time)))))) - jobs-list)) + (for-each (lambda (job) + (if (eqv? (primitive-fork) 0) + (begin + (setgid (passwd:gid (job:user job))) + (setuid (passwd:uid (job:user job))) + (chdir (passwd:dir (job:user job))) + (modify-environment (job:environment job) (job:user job)) + ((job:action job)) + (primitive-exit 0)) + (begin + (set! number-children (+ number-children 1)) + (vector-set! job + 5 + ((job:next-time-function job) + (current-time)))))) + jobs-list)) diff --git a/scm/mcron/redirect.scm b/scm/mcron/redirect.scm index af763cb..312b768 100644 --- a/scm/mcron/redirect.scm +++ b/scm/mcron/redirect.scm @@ -31,7 +31,6 @@ (define-module (mcron redirect) #:export (with-mail-out) - #:use-module (ice-9 regex) #:use-module ((mcron config) :select (config-sendmail)) #:use-module (mcron vixie-time)) diff --git a/scm/mcron/vixie-specification.scm b/scm/mcron/vixie-specification.scm index e7fab0a..ab002ba 100644 --- a/scm/mcron/vixie-specification.scm +++ b/scm/mcron/vixie-specification.scm @@ -30,7 +30,7 @@ read-vixie-file check-system-crontab) #:use-module ((mcron config) :select (config-socket-file)) - #:use-module (mcron mcron-core) + #:use-module (mcron core) #:use-module (mcron job-specifier) #:use-module (mcron redirect) #:use-module (mcron vixie-time)) @@ -162,11 +162,13 @@ (parse-vixie-environment line) (parse-vixie-line line))) (lambda (key exit-code . msg) - (throw 'mcron-error exit-code - (apply string-append - (number->string report-line) - ": " - msg))))))))) + (throw + 'mcron-error + exit-code + (apply string-append + (number->string report-line) + ": " + msg))))))))) |