diff options
Diffstat (limited to 'src/mcron/main.scm')
| -rw-r--r-- | src/mcron/main.scm | 319 |
1 files changed, 18 insertions, 301 deletions
diff --git a/src/mcron/main.scm b/src/mcron/main.scm index db7dfd6..1faa1ae 100644 --- a/src/mcron/main.scm +++ b/src/mcron/main.scm @@ -16,30 +16,22 @@ ;; You should have received a copy of the GNU General Public License along ;; with GNU mcron. If not, see <http://www.gnu.org/licenses/>. -;;; 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-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 base) #: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)) - -(define* (command-name #:optional (command (car (command-line)))) - "Extract the actual command name from COMMAND. This returns the last part -of COMMAND without any non-alphabetic characters. For example \"in.cron\" and -\"./mcron\" will return respectively \"cron\" and \"mcron\". - -When COMMAND is not specified this uses the first element of (command-line)." - (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") command))) + #:export (catch-mcron-error + mcron-error + parse-args + show-version + show-package-information + stdin->string + for-each-file + process-update-request) + #:re-export (option-ref)) (define (mcron-error exit-code . rest) "Print an error message (made up from the parts of REST), and if the @@ -47,7 +39,7 @@ EXIT-CODE error is fatal (present and non-zero) then exit to the system with EXIT-CODE." (with-output-to-port (current-error-port) (lambda () - (for-each display (append (list (command-name) ": ") rest)) + (for-each display (cons "mcron: " rest)) (newline))) (when (and exit-code (not (eq? exit-code 0))) (primitive-exit exit-code))) @@ -60,48 +52,14 @@ and exit with its error code." (lambda (key exit-code . msg) (apply mcron-error exit-code msg)))) -(define command-type - ;; 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. - (let* ((command (command-name)) - (command=? (cut string=? command <>))) - (cond ((command=? "mcron") 'mcron) - ((or (command=? "cron") (command=? "crond")) 'cron) - ((command=? "crontab") 'crontab) - (else (mcron-error 12 "The command name is invalid."))))) +(define (parse-args args option-desc-list) + "Parse ARGS with OPTION-DESC-LIST specification." + (catch 'misc-error + (lambda () (getopt-long args option-desc-list)) + (lambda (key func fmt args . rest) + (mcron-error 1 (apply format (append (list #f fmt) args)))))) -(define options - ;; 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. - (catch - 'misc-error - (lambda () - (getopt-long (command-line) - (append - (case command-type - ((crontab) - '((user (single-char #\u) (value #t)) - (edit (single-char #\e) (value #f)) - (list (single-char #\l) (value #f)) - (remove (single-char #\r) (value #f)))) - (else `((schedule (single-char #\s) (value #t) - (predicate - ,(lambda (value) - (string->number value)))) - (daemon (single-char #\d) (value #f)) - (noetc (single-char #\n) (value #f)) - (stdin (single-char #\i) (value #t) - (predicate - ,(lambda (value) - (or (string=? "vixie" value) - (string=? "guile" value)))))))) - '((version (single-char #\v) (value #f)) - (help (single-char #\h) (value #f)))))) - (lambda (key func fmt args . rest) - (mcron-error 1 (apply format (append (list #f fmt) args)))))) - -(define* (show-version #:optional (command (command-name))) +(define (show-version command) "Display version information for COMMAND and quit." (let* ((name config-package-name) (short-name (cadr (string-split name #\space))) @@ -111,8 +69,7 @@ Copyright (C) 2015 the ~a authors. 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 short-name) - (quit))) + command name version short-name))) (define (show-package-information) "Display where to get help and send bug reports." @@ -123,56 +80,6 @@ General help using GNU software: <http://www.gnu.org/gethelp/>\n" config-package-name config-package-url)) -(define* (show-help #:optional (command (command-name))) - "Display informations of usage for COMMAND and quit." - (simple-format #t "Usage: ~a" command) - (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. - - -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 (delete-run-file) - "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." - (catch #t (lambda () (delete-file config-pid-file) - (delete-file config-socket-file)) - noop) - (quit)) - (define (stdin->string) "Return standard input as a string." (with-output-to-string (lambda () (do ((in (read-char) (read-char))) @@ -188,83 +95,6 @@ is not specified" ((eof-object? file-name) (closedir dir)) (proc file-name)))) -(define process-user-file - (let ((guile-regexp (make-regexp "\\.gui(le)?$")) - (vixie-regexp (make-regexp "\\.vix(ie)?$"))) - (lambda* (file-name #:optional guile-syntax?) - "Process FILE-NAME according its extension. When GUILE-SYNTAX? is TRUE, -force guile syntax usage. If FILE-NAME format is not recognized, it is -silently ignored." - (cond ((string=? "-" file-name) - (if (string=? (option-ref options 'stdin "guile") "vixie") - (read-vixie-port (current-input-port)) - (eval-string (stdin->string)))) - ((or guile-syntax? (regexp-exec guile-regexp file-name)) - (load file-name)) - ((regexp-exec vixie-regexp file-name) - (read-vixie-file file-name)))))) - -(define (process-files-in-user-directory) - "Process files in $XDG_CONFIG_HOME/cron and/or ~/.cron directories (if -$XDG_CONFIG_HOME is not defined uses ~/.config/cron instead)." - (let ((errors 0) - (home-directory (passwd:dir (getpw (getuid))))) - (map (lambda (dir) - (catch #t - (lambda () - (for-each-file - (lambda (file) - (process-user-file (string-append dir "/" file))) - dir)) - (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.")))) - -(define (process-files-in-system-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." - - (define (user-entry name) - ;; Return the user database entry if NAME is valid, otherwise #f. - (false-if-exception (getpwnam name))) - - (catch #t - (lambda () - (for-each-file - (lambda (user) - (and-let* ((entry (user-entry user))) ;crontab without user? - (set-configuration-user entry) - (catch-mcron-error - (read-vixie-file (string-append config-spool-dir "/" user))))) - config-spool-dir)) - (lambda (key . args) - (mcron-error 4 - "You do not have permission to access the system crontabs.")))) - -(define (cron-file-descriptors) - "Establish a socket to listen for updates from a crontab program, and return -a list containing the file descriptors correponding to the files read by -crontab. This requires that command-type is 'cron." - (if (eq? command-type 'cron) - (catch #t - (lambda () - (let ((sock (socket AF_UNIX SOCK_STREAM 0))) - (bind sock AF_UNIX config-socket-file) - (listen sock 5) - (list sock))) - (lambda (key . args) - (delete-file config-pid-file) - (mcron-error 1 "Cannot bind to UNIX socket " config-socket-file))) - '())) - (define (process-update-request fdes-list) "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 @@ -286,116 +116,3 @@ comes in on the above socket." (remove-user-jobs user) (set-configuration-user user) (read-vixie-file (string-append config-spool-dir "/" user-name))))))) - - -;;; -;;; Entry point. -;;; - -(define (main . args) - ;; Turn debugging on if indicated. - (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) - ;; XXX: 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 #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) - (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 (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. - (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 base, 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 FDES-LIST. - (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)))))) |