AboutSummaryRefsLogTreeCommitDiffStats
path: root/scm/mcron/main.scm
diff options
context:
space:
mode:
authorMathieu Lirzin <mthl@gnu.org>2016-05-07 11:09:44 +0200
committerMathieu Lirzin <mthl@gnu.org>2016-05-07 23:38:53 +0200
commit995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47 (patch)
tree1f12ba3e4218d91a8736df5a5fa6eb82ffe39181 /scm/mcron/main.scm
parentbb8703b679509fe3b842f9f24f6871b3c2889916 (diff)
downloadmcron-995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47.tar.gz
mcron-995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47.tar.bz2
mcron-995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47.zip
all: Rename 'scm' directory to 'src'.
* scm/mcron/config.scm.in: Rename to ... * src/mcron/config.scm.in: ... this. * scm/mcron/crontab.scm: Rename to ... * src/mcron/crontab.scm: ... this. * scm/mcron/environment.scm: Rename to ... * src/mcron/environment.scm: ... this. * scm/mcron/job-specifier.scm: Rename to ... * src/mcron/job-specifier.scm: ... this. * scm/mcron/main.scm: Rename to ... * src/mcron/main.scm: ... this. * scm/mcron/mcron-core.scm: Rename to ... * src/mcron/mcron-core.scm: ... this. * scm/mcron/redirect.scm: Rename to ... * src/mcron/redirect.scm: ... this. * scm/mcron/vixie-specification.scm: Rename to ... * src/mcron/vixie-specification.scm: ... this. * scm/mcron/vixie-time.scm: Rename to ... * src/mcron/vixie-time.scm: ... this. * mcron.c: Rename to ... * src/mcron.c: ... this. * Makefile.am: Adapt to them. * build-aux/pre-inst-env.in: Likewise. * configure.ac (AC_CONFIG_FILES): Likewise. (AC_CONFIG_HEADER): Set to 'src/config.h'. * .gitignore: Update.
Diffstat (limited to 'scm/mcron/main.scm')
-rw-r--r--scm/mcron/main.scm401
1 files changed, 0 insertions, 401 deletions
diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm
deleted file mode 100644
index 1f2b068..0000000
--- a/scm/mcron/main.scm
+++ /dev/null
@@ -1,401 +0,0 @@
-;; Copyright (C) 2015, 2016 Mathieu Lirzin
-;; Copyright (C) 2003, 2012 Dale Mellor
-;;
-;; 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/>.
-
-;;; 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 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))
-
-(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)))
-
-(define (mcron-error exit-code . rest)
- "Print an error message (made up from the parts of REST), and if the
-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))
- (newline)))
- (when (and exit-code (not (eq? exit-code 0)))
- (primitive-exit exit-code)))
-
-(define-syntax-rule (catch-mcron-error exp ...)
- "Evaluate EXP .... if an 'mcron-error exception occurs, print its diagnostics
-and exit with its error code."
- (catch 'mcron-error
- (lambda () exp ...)
- (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 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)))
- "Display version information for COMMAND and quit."
- (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 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)))
-
-(define (show-package-information)
- "Display where to get help and send bug reports."
- (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* (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)))
- ((eof-object? in))
- (display in)))))
-
-(define (for-each-file proc directory)
- "Apply PROC to each file in DIRECTORY. DIRECTORY must be a valid directory name.
-PROC must be a procedure that take one file name argument. The return value
-is not specified"
- (let ((dir (opendir directory)))
- (do ((file-name (readdir dir) (readdir dir)))
- ((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
-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."
- (let* ((sock (car (accept (car fdes-list))))
- (user-name (read-line sock)))
- (close sock)
- (set-configuration-time (current-time))
- (catch-mcron-error
- (if (string=? user-name "/etc/crontab")
- (begin
- (clear-system-jobs)
- (use-system-job-list)
- (read-vixie-file "/etc/crontab" parse-system-vixie-line)
- (use-user-job-list))
- (let ((user (getpw user-name)))
- (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 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 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))))))