dmbcs/mcron
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

all: Rename 'scm' directory to 'src'.

Browse source 
* 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.
This commit is contained in:
Mathieu Lirzin 2016-05-07 11:09:44 +02:00
commit 995bc9ca6e
14 changed files with 20 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

87
src/mcron.c Normal file
View file

@ -0,0 +1,87 @@
/* mcron - run jobs at scheduled times
Copyright (C) 2015, 2016 Mathieu Lirzin
Copyright (C) 2003, 2014 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 C code represents a thin wrapper around the Guile code of Mcron. It
is needed because the crontab personality requires SUID which is not
permitted for executable scripts. */
#include "config.h"
#include <libguile.h>
#include <signal.h>
#include <stdlib.h>
#include <string.h>
/* Forward declarations. */
static void inner_main (void *closure, int argc, char **argv);
static void react_to_terminal_signal (int sig);
static SCM set_cron_signals (void);
int
main (int argc, char **argv)
{
scm_boot_guile (argc, argv, inner_main, 0);
return EXIT_SUCCESS;
}
/* Launch the Mcron Guile main program. */
static void
inner_main (void *closure, int argc, char **argv)
{
/* Set Guile load paths to ensure that Mcron modules will be found. */
if (getenv ("MCRON_UNINSTALLED") == NULL)
{
scm_c_eval_string ("(set! %load-path (cons \""
PACKAGE_LOAD_PATH "\" %load-path))");
scm_c_eval_string ("(set! %load-compiled-path (cons \""
PACKAGE_LOAD_PATH "\" %load-compiled-path))");
}
scm_set_current_module (scm_c_resolve_module ("mcron main"));
/* Register set_cron_signals to be called from Guile. */
scm_c_define_gsubr ("c-set-cron-signals", 0, 0, 0, set_cron_signals);
scm_c_eval_string ("(main)");
}
/* Set up all the signal handlers as required by the cron personality. This
is necessary to perform the signal processing in C because the sigaction
function won't work when called from Guile. */
static SCM
set_cron_signals ()
{
static struct sigaction sa;
memset (&sa, 0, sizeof (sa));
sa.sa_handler = react_to_terminal_signal;
sigaction (SIGTERM, &sa, 0);
sigaction (SIGINT, &sa, 0);
sigaction (SIGQUIT, &sa, 0);
sigaction (SIGHUP, &sa, 0);
return SCM_BOOL_T;
}
/* Handle signal SIG and exit. All signals that mcron handles will produce
the same behavior so we don't need to use SIG in the implementation. */
static void
react_to_terminal_signal (int sig)
{
scm_c_eval_string ("(delete-run-file)");
exit (EXIT_FAILURE);
}

39
src/mcron/config.scm.in Normal file
View file

@ -0,0 +1,39 @@
;; -*-scheme-*-
;; Copyright (C) 2015 Mathieu Lirzin
;; Copyright (C) 2003 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/>.
;; Some constants set by the configuration process.
(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@")
(define-public config-socket-file "@CONFIG_SOCKET_FILE@")
(define-public config-allow-file "@CONFIG_ALLOW_FILE@")
(define-public config-deny-file "@CONFIG_DENY_FILE@")
(define-public config-pid-file "@CONFIG_PID_FILE@")
(define-public config-tmp-dir "@CONFIG_TMP_DIR@")

228
src/mcron/crontab.scm Normal file
View file

@ -0,0 +1,228 @@
;; Copyright (C) 2003, 2014 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/>.
;; Apart from the collecting of options and the handling of --help and --version
;; (which are done in the main.scm file), this file provides all the
;; functionality of the crontab personality. It is designed to be loaded and run
;; once, and then the calling program can exit and the crontab program will have
;; completed its function.
;; Procedure to communicate with running cron daemon that a user has modified
;; his crontab. The user name is written to the /var/cron/socket UNIX socket.
(let ((hit-server
(lambda (user-name)
(catch #t (lambda ()
(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
(connect socket AF_UNIX config-socket-file)
(display user-name socket)
(close socket)))
(lambda (key . args)
(display "Warning: a cron daemon is not running.\n")))))
;; Procedure to scan a file containing one user name per line (such as
;; /var/cron/allow and /var/cron/deny), and determine if the given name is in
;; there. The procedure returns #t, #f, or '() if the file does not exist.
(in-access-file?
(lambda (file name)
(catch #t (lambda ()
(with-input-from-file
file
(lambda ()
(let loop ((input (read-line)))
(if (eof-object? input)
#f
(if (string=? input name)
#t
(loop (read-line))))))))
(lambda (key . args) '()))))
;; This program should have been installed SUID root. Here we get the
;; passwd entry for the real user who is running this program.
(crontab-real-user (passwd:name (getpw (getuid)))))
;; If the real user is not allowed to use crontab due to the /var/cron/allow
;; and/or /var/cron/deny files, bomb out now.
(if (or (eq? (in-access-file? config-allow-file crontab-real-user) #f)
(eq? (in-access-file? config-deny-file crontab-real-user) #t))
(mcron-error 6 "Access denied by system operator."))
;; Check that no more than one of the mutually exclusive options are being
;; used.
(if (> (+ (if (option-ref options 'edit #f) 1 0)
(if (option-ref options 'list #f) 1 0)
(if (option-ref options 'remove #f) 1 0))
1)
(mcron-error 7 "Only one of options -e, -l or -r can be used."))
;; Check that a non-root user is trying to read someone else's files.
(if (and (not (eqv? (getuid) 0))
(option-ref options 'user #f))
(mcron-error 8 "Only root can use the -u option."))
(let (
;; Iff the --user option is given, the crontab-user may be different
;; from the real user.
(crontab-user (option-ref options 'user crontab-real-user))
;; So now we know which crontab file we will be manipulating.
(crontab-file (string-append config-spool-dir "/" crontab-user))
;; Display the prompt and wait for user to type his choice. Return #t if
;; the answer begins with 'y' or 'Y', return #f if it begins with 'n' or
;; 'N', otherwise ask again.
(get-yes-no (lambda (prompt . re-prompt)
(if (not (null? re-prompt))
(display "Please answer y or n.\n"))
(display (string-append prompt " "))
(let ((r (read-line)))
(if (not (string-null? r))
(case (string-ref r 0)
((#\y #\Y) #t)
((#\n #\N) #f)
(else (get-yes-no prompt #t)))
(get-yes-no prompt #t))))))
;; There are four possible sub-personalities to the crontab personality:
;; list, remove, edit and replace (when the user uses no options but
;; supplies file names on the command line).
(cond
;; In the list personality, we simply open the crontab and copy it
;; character-by-character to the standard output. If anything goes wrong, it
;; can only mean that this user does not have a crontab file.
((option-ref options 'list #f)
(catch #t (lambda ()
(with-input-from-file crontab-file (lambda ()
(do ((input (read-char) (read-char)))
((eof-object? input))
(display input)))))
(lambda (key . args)
(display (string-append "No crontab for "
crontab-user
" exists.\n")))))
;; In the edit personality, we determine the name of a temporary file and an
;; editor command, copy an existing crontab file (if it is there) to the
;; temporary file, making sure the ownership is set so the real user can edit
;; it; once the editor returns we try to read the file to check that it is
;; parseable (but do nothing more with the configuration), and if it is okay
;; (this program is still running!) we move the temporary file to the real
;; crontab, wake the cron daemon up, and remove the temporary file. If the
;; parse fails, we give user a choice of editing the file again or quitting
;; the program and losing all changes made.
((option-ref options 'edit #f)
(let ((temp-file (string-append config-tmp-dir
"/crontab."
(number->string (getpid)))))
(catch #t (lambda () (copy-file crontab-file temp-file))
(lambda (key . args) (with-output-to-file temp-file noop)))
(chown temp-file (getuid) (getgid))
(let retry ()
(system (string-append
(or (getenv "VISUAL") (getenv "EDITOR") "vi")
" "
temp-file))
(catch 'mcron-error
(lambda () (read-vixie-file temp-file))
(lambda (key exit-code . msg)
(apply mcron-error 0 msg)
(if (get-yes-no "Edit again?")
(retry)
(begin
(mcron-error 0 "Crontab not changed")
(primitive-exit 0))))))
(copy-file temp-file crontab-file)
(delete-file temp-file)
(hit-server crontab-user)))
;; In the remove personality we simply make an effort to delete the crontab and
;; wake the daemon. No worries if this fails.
((option-ref options 'remove #f)
(catch #t (lambda () (delete-file crontab-file)
(hit-server crontab-user))
noop))
;; !!!! This comment is wrong.
;; In the case of the replace personality we loop over all the arguments on the
;; command line, and for each one parse the file to make sure it is parseable
;; (but subsequently ignore the configuration), and all being well we copy it
;; to the crontab location; we deal with the standard input in the same way but
;; different. :-) In either case the server is woken so that it will read the
;; newly installed crontab.
((not (null? (option-ref options '() '())))
(let ((input-file (car (option-ref options '() '()))))
(catch-mcron-error
(if (string=? input-file "-")
(let ((input-string (stdin->string)))
(read-vixie-port (open-input-string input-string))
(with-output-to-file crontab-file (lambda ()
(display input-string))))
(begin
(read-vixie-file input-file)
(copy-file input-file crontab-file))))
(hit-server crontab-user)))
;; 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.")))
)) ;; End of file-level let-scopes.

97
src/mcron/environment.scm Normal file
View file

@ -0,0 +1,97 @@
;; Copyright (C) 2015, 2016 Mathieu Lirzin
;; Copyright (C) 2003 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 file defines the variable current-environment-mods, and the procedures
;; append-environment-mods (which is available to user configuration files),
;; clear-environment-mods and modify-environment. The idea is that the
;; current-environment-mods is a list of pairs of environment names and values,
;; and represents the cumulated environment settings in a configuration
;; file. When a job definition is seen in a configuration file, the
;; current-environment-mods are copied into the internal job description, and
;; when the job actually runs these environment modifications are applied to
;; the UNIX environment in which the job runs.
(define-module (mcron environment)
#:export (modify-environment
clear-environment-mods
append-environment-mods
get-current-environment-mods-copy))
;; As we parse configuration files, we build up an alist of environment
;; variables here.
(define current-environment-mods '())
;; Each time a job is added to the system, we take a snapshot of the current
;; set of environment modifiers.
(define (get-current-environment-mods-copy)
(list-copy current-environment-mods))
;; When we start to parse a new configuration file, we want to start with a
;; fresh environment (actually an umodified version of the pervading mcron
;; environment).
(define (clear-environment-mods)
(set! current-environment-mods '()))
;; Procedure to add another environment setting to the alist above. This is
;; used both implicitly by the Vixie parser, and can be used directly by users
;; in scheme configuration files. The return value is purely for the
;; convenience of the parse-vixie-environment in the vixie-specification module
;; (yuk).
(define (append-environment-mods name value)
(set! current-environment-mods (append current-environment-mods
(list (cons name value))))
#t)
(define (modify-environment env passwd-entry)
"Modify the environment (in the UNIX sense) by setting the variables from
ENV and some default ones which are modulated by PASSWD-ENTRY. \"LOGNAME\"
and \"USER\" environment variables can't be overided by ENV. ENV must be an
alist which associate environment variables to their value. PASSWD-ENTRY must
be an object representing user information which corresponds to a valid entry
in /etc/passwd. The return value is not specified."
(for-each (lambda (pair) (setenv (car pair) (cdr pair)))
(let ((home-dir (passwd:dir passwd-entry))
(user-name (passwd:name passwd-entry)))
(append
;; Default environment variables which can be overided by ENV.
`(("HOME" . ,home-dir)
("CWD" . ,home-dir)
("SHELL" . ,(passwd:shell passwd-entry))
("TERM" . #f)
("TERMCAP" . #f))
env
;; Environment variables with imposed values.
`(("LOGNAME" . ,user-name)
("USER" . ,user-name))))))

253
src/mcron/job-specifier.scm Normal file
View file

@ -0,0 +1,253 @@
;; Copyright (C) 2003 Dale Mellor
;; Copyright (C) 2016 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/>.
;; This module defines all the functions that can be used by scheme mcron
;; configuration files, namely the procedures for working out next times, the
;; job procedure for registering new jobs (actually a wrapper around the core
;; add-job function), and the procedure for declaring environment modifications.
(define-module (mcron job-specifier)
#:use-module (ice-9 match)
#:use-module (mcron core)
#:use-module (mcron environment)
#:use-module (mcron vixie-time)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:re-export (append-environment-mods)
#:export (range
next-year-from next-year
next-month-from next-month
next-day-from next-day
next-hour-from next-hour
next-minute-from next-minute
next-second-from next-second
set-configuration-user
set-configuration-time
job))
(define* (range start end #:optional (step 1))
"Produces a list of values from START up to (but not including) END. An
optional STEP may be supplied, and (if positive) only every step'th value will
go into the list. For example, (range 1 6 2) returns '(1 3 5)."
(unfold (cut >= <> end) identity (cute + <> (max step 1)) start))
(define (%find-best-next current next-list)
;; Takes a value and a list of possible next values (all assumed less than
;; 9999). It returns a pair consisting of the smallest element of the
;; NEXT-LIST, and the smallest element larger than the CURRENT value. If an
;; example of the latter cannot be found, 9999 will be returned.
(let loop ((smallest 9999) (closest+ 9999) (lst next-list))
(match lst
(() (cons smallest closest+))
((time . rest)
(loop (min time smallest)
(if (> time current) (min time closest+) closest+)
rest)))))
;; Internal function to return the time corresponding to some near future
;; hour. If hour-list is not supplied, the time returned corresponds to the
;; start of the next hour of the day.
;;
;; If the hour-list is supplied the time returned corresponds to the first hour
;; of the day in the future which is contained in the list. If all the values in
;; the list are less than the current hour, then the time returned will
;; correspond to the first hour in the list *on the following day*.
;;
;; ... except that the function is actually generalized to deal with seconds,
;; minutes, etc., in an obvious way :-)
;;
;; Note that value-list always comes from an optional argument to a procedure,
;; so is wrapped up as the first element of a list (i.e. it is a list inside a
;; list).
(define (bump-time time value-list component higher-component
set-component! set-higher-component!)
(if (null? value-list)
(set-component! time (+ (component time) 1))
(let ((best-next (%find-best-next (component time) (car value-list))))
(if (eqv? 9999 (cdr best-next))
(begin
(set-higher-component! time (+ (higher-component time) 1))
(set-component! time (car best-next)))
(set-component! time (cdr best-next)))))
(car (mktime time)))
;; Set of configuration methods which use the above general function to bump
;; specific components of time to the next legitimate value. In each case, all
;; the components smaller than that of interest are taken to zero, so that for
;; example the time of the next year will be the time at which the next year
;; actually starts.
(define (next-year-from current-time . year-list)
(let ((time (localtime current-time)))
(set-tm:mon time 0)
(set-tm:mday time 1)
(set-tm:hour time 0)
(set-tm:min time 0)
(set-tm:sec time 0)
(bump-time time year-list tm:year tm:year set-tm:year set-tm:year)))
(define (next-month-from current-time . month-list)
(let ((time (localtime current-time)))
(set-tm:mday time 1)
(set-tm:hour time 0)
(set-tm:min time 0)
(set-tm:sec time 0)
(bump-time time month-list tm:mon tm:year set-tm:mon set-tm:year)))
(define (next-day-from current-time . day-list)
(let ((time (localtime current-time)))
(set-tm:hour time 0)
(set-tm:min time 0)
(set-tm:sec time 0)
(bump-time time day-list tm:mday tm:mon set-tm:mday set-tm:mon)))
(define (next-hour-from current-time . hour-list)
(let ((time (localtime current-time)))
(set-tm:min time 0)
(set-tm:sec time 0)
(bump-time time hour-list tm:hour tm:mday set-tm:hour set-tm:mday)))
(define (next-minute-from current-time . minute-list)
(let ((time (localtime current-time)))
(set-tm:sec time 0)
(bump-time time minute-list tm:min tm:hour set-tm:min set-tm:hour)))
(define (next-second-from current-time . second-list)
(let ((time (localtime current-time)))
(bump-time time second-list tm:sec tm:min set-tm:sec set-tm:min)))
;; The current-action-time is the time a job was last run, the time from which
;; the next time to run a job must be computed. (When the program is first run,
;; this time is set to the configuration time so that jobs run from that moment
;; forwards.) Once we have this, we supply versions of the time computation
;; commands above which implicitly assume this value.
(define current-action-time 0)
;; We want to provide functions which take a single optional argument (as well
;; as implicitly the current action time), but unlike usual scheme behaviour if
;; the argument is missing we want to act like it is really missing, and if it
;; is there we want to act like it is a genuine argument, not a list of
;; optionals.
(define (maybe-args function args)
(if (null? args)
(function current-action-time)
(function current-action-time (car args))))
;; These are the convenience functions we were striving to define for the
;; configuration files. They are wrappers for the next-X-from functions above,
;; but implicitly use the current-action-time for the time argument.
(define (next-year . args) (maybe-args next-year-from args))
(define (next-month . args) (maybe-args next-month-from args))
(define (next-day . args) (maybe-args next-day-from args))
(define (next-hour . args) (maybe-args next-hour-from args))
(define (next-minute . args) (maybe-args next-minute-from args))
(define (next-second . args) (maybe-args next-second-from args))
;; The default user for running jobs is the current one (who invoked this
;; program). There are exceptions: when cron parses /etc/crontab the user is
;; specified on each individual line; when cron parses /var/cron/tabs/* the user
;; is derived from the filename of the crontab. These cases are dealt with by
;; mutating this variable. Note that the variable is only used at configuration
;; time; a UID is stored with each job and it is that which takes effect when
;; the job actually runs.
(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))
;; The job function, available to configuration files for adding a job rule to
;; the system.
;;
;; Here we must 'normalize' the next-time-function so that it is always a lambda
;; function which takes one argument (the last time the job ran) and returns a
;; single value (the next time the job should run). If the input value is a
;; string this is parsed as a Vixie-style time specification, and if it is a
;; list then we arrange to eval it (but note that such lists are expected to
;; ignore the function parameter - the last run time is always read from the
;; current-action-time global variable). A similar normalization is applied to
;; the action.
;;
;; Here we also compute the first time that the job is supposed to run, by
;; finding the next legitimate time from the current configuration time (set
;; right at the top of this program).
(define (job time-proc action . displayable)
(let ((action (cond ((procedure? action) action)
((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)"))))
(time-proc
(cond ((procedure? time-proc) time-proc)
((string? time-proc) (parse-vixie-time time-proc))
((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)"))))
(displayable
(cond ((not (null? displayable)) (car displayable))
((procedure? action) "Lambda function")
((string? action) action)
((list? action) (with-output-to-string
(lambda () (display action)))))))
(add-job (lambda (current-time)
(set! current-action-time current-time) ;; ?? !!!! Code
;; Contributed by Sergey Poznyakoff to allow for daylight savings
;; time changes.
(let* ((next (time-proc current-time))
(gmtoff (tm:gmtoff (localtime next)))
(d (+ next (- gmtoff
(tm:gmtoff (localtime current-time))))))
(if (eqv? (tm:gmtoff (localtime d)) gmtoff)
d
next)))
action
displayable
configuration-time
configuration-user)))

401
src/mcron/main.scm Normal file
View file

@ -0,0 +1,401 @@
;; 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))))))

270
src/mcron/mcron-core.scm Normal file
View file

@ -0,0 +1,270 @@
;; Copyright (C) 2015, 2016 Mathieu Lirzin
;; Copyright (C) 2003 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/>.
(define-module (mcron core)
#:use-module (mcron environment)
#:use-module (srfi srfi-9)
#:export (add-job
remove-user-jobs
get-schedule
run-job-loop
;; These three are deprecated and not documented.
use-system-job-list
use-user-job-list
clear-system-jobs)
#:re-export (clear-environment-mods
append-environment-mods))
(use-modules (srfi srfi-1) ;; For remove.
(srfi srfi-2)) ;; For and-let*.
;; 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)
;;
;; 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
;; run. The next-time element is the only one that is modified during the
;; running of a cron process (i.e. all the others are set once and for all at
;; configuration time).
;;
;; The reason we maintain two lists is that jobs in /etc/crontab may be placed
;; in one, and all other jobs go in the other. This makes it possible to remove
;; all the jobs in the first list in one go, and separately we can remove all
;; jobs from the second list which belong to a particular user. This behaviour
;; is required for full vixie compatibility.
(define system-job-list '())
(define user-job-list '())
(define configuration-source 'user)
(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) ;object : 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!))
;; Remove jobs from the user-job-list belonging to this user.
(define (remove-user-jobs user)
(if (or (string? user)
(integer? user))
(set! user (getpw user)))
(set! user-job-list
(remove (lambda (job) (eqv? (passwd:uid user)
(passwd:uid (job:user job))))
user-job-list)))
;; Remove all the jobs on the system job list.
(define (clear-system-jobs) (set! system-job-list '()))
;; Add a new job with the given specifications to the head of the appropriate
;; jobs list.
(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))))
(if (eq? configuration-source 'user)
(set! user-job-list (cons entry user-job-list))
(set! system-job-list (cons entry system-job-list)))))
;; Procedure to locate the jobs in the global job-list with the lowest
;; (soonest) next-times. These are the jobs for which we must schedule the mcron
;; program (under any personality) to next wake up. The return value is a cons
;; cell consisting of the next time (maintained in the next-time variable) and a
;; list of the job entries that are to run at this time (maintained in the
;; next-jobs-list variable).
;;
;; The procedure works by first obtaining the time of the first job on the list,
;; and setting this job in the next-jobs-list. Then for each other entry on the
;; job-list, either the job runs earlier than any other that have been scanned,
;; in which case the next-time and next-jobs-list are re-initialized to
;; accomodate, or the job runs at the same time as the next job, in which case
;; the next-jobs-list is simply augmented with the new job, or else the job runs
;; later than others noted in which case we ignore it for now and continue to
;; recurse the list.
(define (find-next-jobs)
(let ((job-list (append system-job-list user-job-list)))
(if (null? job-list)
'(#f . '())
(let ((next-time 2000000000)
(next-jobs-list '()))
(for-each
(lambda (job)
(let ((this-time (job:next-time job)))
(cond ((< this-time next-time)
(set! next-time this-time)
(set! next-jobs-list (list job)))
((eqv? this-time next-time)
(set! next-jobs-list (cons job next-jobs-list))))))
job-list)
(cons next-time next-jobs-list)))))
;; Create a string containing a textual list of the next count jobs to run.
;;
;; Enter a loop of displaying the next set of jobs to run, artificially
;; forwarding the time to the next time point (instead of waiting for it to
;; occur as we would do in a normal run of mcron), and recurse around the loop
;; count times.
;;
;; Note that this has the effect of mutating the job timings. Thus the program
;; must exit after calling this function; the internal data state will be left
;; unusable.
(define (get-schedule count)
(with-output-to-string
(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)))))))
;; For proper housekeeping, it is necessary to keep a record of the number of
;; child processes we fork off to run the jobs.
(define number-children 0)
;; For every job on the list, fork a process to run it (noting the fact by
;; increasing the number-children counter), and in the new process set up the
;; run-time environment exactly as it should be before running the job proper.
;;
;; In the parent, update the job entry by computing the next time the job needs
;; 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))
;; Give any zombie children a chance to die, and decrease the number known to
;; exist.
(define (child-cleanup)
(do () ((or (<= number-children 0)
(eqv? (car (waitpid WAIT_ANY WNOHANG)) 0)))
(set! number-children (- number-children 1))))
;; Now the main loop. 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.
;;
;; 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 the
;; situation (it will eventually re-call this function, thus maintaining the
;; loop).
(define (run-job-loop . fd-list)
(call-with-current-continuation
(lambda (break)
(let ((fd-list (if (null? fd-list) '() (car fd-list))))
(let loop ()
(let* ((next-jobs (find-next-jobs))
(next-time (car next-jobs))
(next-jobs-list (cdr next-jobs))
(sleep-time (if next-time (- next-time (current-time))
2000000000)))
(and (> sleep-time 0)
(if (not (null?
(catch 'system-error
(lambda ()
(car (select fd-list '() '() sleep-time)))
(lambda (key . args) ;; Exception add by Sergey
;; Poznyakoff.
(if (member (car (last args))
(list EINTR EAGAIN))
(begin
(child-cleanup) '())
(apply throw key args))))))
(break)))
(run-jobs next-jobs-list)
(child-cleanup)
(loop)))))))

190
src/mcron/redirect.scm Normal file
View file

@ -0,0 +1,190 @@
;; Copyright (C) 2003 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 module provides the (with-mail-out action . user) procedure. This
;; procedure runs the action in a child process, allowing the user control over
;; the input and output (including standard error). The input is governed (only
;; in the case of a string action) by the placing of percentage signs in the
;; string; the first delimits the true action from the standard input, and
;; subsequent ones denote newlines to be placed into the input. The output (if
;; there actually is any) is controlled by the MAILTO environment variable. If
;; this is not defined, output is e-mailed to the user passed as argument, if
;; any, or else the owner of the action; if defined but empty then any output is
;; sunk to /dev/null; otherwise output is e-mailed to the address held in the
;; MAILTO variable.
(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))
;; An action string consists of a sequence of characters forming a command
;; executable by the shell, possibly followed by an non-escaped percentage
;; sign. The text after the percentage sign is to be fed to the command's
;; standard input, with further unescaped percents being substituted with
;; newlines. The escape character can itself be escaped.
;;
;; This regexp separates the two halves of the string, and indeed determines if
;; the second part is present.
(define action-string-regexp (make-regexp "((\\\\%|[^%])*)%(.*)$"))
;; This regexp identifies an escaped percentage sign.
(define e-percent (make-regexp "\\\\%"))
;; Function to execute some action (this may be a shell command, lamdba function
;; or list of scheme procedures) in a forked process, with the input coming from
;; the string, and output (including the error output) being sent to a pipe
;; opened on a mail transport.
(use-modules (ice-9 popen))
(define (with-mail-out action . user)
;; Determine the name of the user who is to recieve the mail, looking for a
;; name in the optional user argument, then in the MAILTO environment
;; variable, and finally in the LOGNAME environment variable. (The case
;; MAILTO="" is dealt with specially below.)
(let* ((mailto (getenv "MAILTO"))
(user (cond (mailto mailto)
((not (null? user)) (car user))
(else (getenv "LOGNAME"))))
(parent->child (pipe))
(child->parent (pipe))
(child-pid (primitive-fork)))
;; The child process. Close redundant ends of pipes, remap the standard
;; streams, and run the action, taking care to chop off the input part of an
;; action string.
(if (eqv? child-pid 0)
(begin
(close (cdr parent->child))
(close (car child->parent))
(dup2 (port->fdes (car parent->child)) 0)
(close (car parent->child))
(dup2 (port->fdes (cdr child->parent)) 1)
(close (cdr child->parent))
(dup2 1 2)
(cond ((string? action)
(let ((match (regexp-exec action-string-regexp action)))
(system (if match
(let ((action (match:substring match 1)))
(do ((match (regexp-exec e-percent action)
(regexp-exec e-percent action)))
((not match))
(set! action (string-append
(match:prefix match)
"%"
(match:suffix match))))
action)
action))))
((procedure? action) (action))
((list? action) (primitive-eval action)))
(primitive-exit 0)))
;; The parent process. Get rid of redundant pipe ends.
(close (car parent->child))
(close (cdr child->parent))
;; Put stuff to child from after '%' in command line, replacing
;; other %'s with newlines. Ugly or what?
(if (string? action)
(let ((port (cdr parent->child))
(match (regexp-exec action-string-regexp action)))
(if (and match
(match:substring match 3))
(with-input-from-string (match:substring match 3)
(lambda ()
(let loop ()
(let ((next-char (read-char)))
(if (not (eof-object? next-char))
(cond
((char=? next-char #\%)
(newline port)
(loop))
((char=? next-char #\\)
(let ((escape (read-char)))
(if (eof-object? escape)
(display #\\ port)
(if (char=? escape #\%)
(begin
(display #\% port)
(loop))
(begin
(display #\\ port)
(display escape port)
(loop))))))
(else
(display next-char port)
(loop)))))))))))
;; So the child process doesn't hang on to its input expecting more stuff.
(close (cdr parent->child))
;; That's got streaming into the child's input out of the way, now we stream
;; the child's output to a mail sink, but only if there is something there
;; in the first place.
(if (eof-object? (peek-char (car child->parent)))
(read-char (car child->parent))
(begin
(set-current-output-port (if (and (string? mailto)
(string=? mailto ""))
(open-output-file "/dev/null")
(open-output-pipe
(string-append config-sendmail
" "
user))))
(set-current-input-port (car child->parent))
(display "To: ") (display user) (newline)
(display "From: mcron") (newline)
(display (string-append "Subject: " user "@" (gethostname)))
(newline)
(newline)
(do ((next-char (read-char) (read-char)))
((eof-object? next-char))
(display next-char))))
(close (car child->parent))
(waitpid child-pid)))

207
src/mcron/vixie-specification.scm Normal file
View file

@ -0,0 +1,207 @@
;; Copyright (C) 2003 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 file provides methods for reading a complete Vixie-style configuration
;; file, either from a real file or an already opened port. It also exposes the
;; method for parsing the time-specification part of a Vixie string, so that
;; these can be used to form the next-time-function of a job in a Guile
;; configuration file.
(define-module (mcron vixie-specification)
#:export (parse-user-vixie-line
parse-system-vixie-line
read-vixie-port
read-vixie-file
check-system-crontab)
#:use-module ((mcron config) :select (config-socket-file))
#:use-module (mcron core)
#:use-module (mcron job-specifier)
#:use-module (mcron redirect)
#:use-module (mcron vixie-time))
(use-modules (ice-9 regex) (ice-9 rdelim)
(srfi srfi-1) (srfi srfi-2) (srfi srfi-13) (srfi srfi-14))
;; A line in a Vixie-style crontab file which gives a command specification
;; carries two pieces of information: a time specification consisting of five
;; space-separated items, and a command which is also separated from the time
;; specification by a space. The line is broken into the two components, and the
;; job procedure run to add the two pieces of information to the job list (this
;; will in turn use the above function to turn the time specification into a
;; function for computing future run times of the command).
(define parse-user-vixie-line-regexp
(make-regexp "^[[:space:]]*(([^[:space:]]+[[:space:]]+){5})(.*)$"))
(define (parse-user-vixie-line line)
(let ((match (regexp-exec parse-user-vixie-line-regexp line)))
(if (not match)
(throw 'mcron-error 10 "Bad job line in Vixie file."))
(job (match:substring match 1)
(lambda () (with-mail-out (match:substring match 3)))
(match:substring match 3))))
;; The case of reading a line from /etc/crontab is similar to above but the user
;; ID appears in the sixth field, before the action.
(define parse-system-vixie-line-regexp
(make-regexp (string-append "^[[:space:]]*(([^[:space:]]+[[:space:]]+){5})"
"([[:alpha:]][[:alnum:]_]*)[[:space:]]+(.*)$")))
(define (parse-system-vixie-line line)
(let ((match (regexp-exec parse-system-vixie-line-regexp line)))
(if (not match)
(throw 'mcron-error 11 "Bad job line in /etc/crontab."))
(let ((user (match:substring match 3)))
(set-configuration-user user)
(job (match:substring match 1)
(lambda () (with-mail-out (match:substring match 4)
user))
(match:substring match 4)))))
;; Procedure to act on an environment variable specification in a Vixie-style
;; configuration file, by adding an entry to the alist above. Returns #t if the
;; operation was successful, #f if the line could not be interpreted as an
;; environment specification.
(define parse-vixie-environment-regexp1
(make-regexp
"^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*\"(.*)\"[ \t]*$"))
(define parse-vixie-environment-regexp2
(make-regexp
"^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*'(.*)'[ \t]*$"))
(define parse-vixie-environment-regexp3
(make-regexp
"^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*(.*[^ \t])[ \t]*$"))
(define parse-vixie-environment-regexp4
(make-regexp
"^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*$"))
(define (parse-vixie-environment string)
(let ((match (or (regexp-exec parse-vixie-environment-regexp1 string)
(regexp-exec parse-vixie-environment-regexp2 string)
(regexp-exec parse-vixie-environment-regexp3 string))))
(if match
(append-environment-mods (match:substring match 1)
(match:substring match 2))
(and-let* ((match (regexp-exec parse-vixie-environment-regexp4 string)))
(append-environment-mods (match:substring match 1) #f)))))
;; The next procedure reads an entire Vixie-style file. For each line in the
;; file there are three possibilities (after continuation lines have been
;; appended): the line is blank or contains only a comment, the line contains an
;; environment modifier which will be handled in the mcron environment module,
;; or the line contains a command specification in which case we use the
;; procedure above to add an entry to the internal job list.
;;
;; Note that the environment modifications are cleared, so that there is no
;; interference between crontab files (this might lead to unpredictable
;; behaviour because the order in which crontab files are processed, if there is
;; more than one, is generally undefined).
(define read-vixie-file-comment-regexp
(make-regexp "^[[:space:]]*(#.*)?$"))
(define (read-vixie-port port . parse-vixie-line)
(clear-environment-mods)
(if port
(let ((parse-vixie-line
(if (null? parse-vixie-line) parse-user-vixie-line
(car parse-vixie-line))))
(do ((line (read-line port) (read-line port))
(line-number 1 (1+ line-number)))
((eof-object? line))
(let ((report-line line-number))
;; If the line ends with \, append the next line.
(while (and (>= (string-length line) 1)
(char=? (string-ref line
(- (string-length line) 1))
#\\))
(let ((next-line (read-line port)))
(if (eof-object? next-line)
(set! next-line ""))
(set! line-number (1+ line-number))
(set! line
(string-append
(substring line 0 (- (string-length line) 1))
next-line))))
(catch 'mcron-error
(lambda ()
;; Consider the three cases mentioned in the description.
(or (regexp-exec read-vixie-file-comment-regexp line)
(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)))))))))
;; If a file cannot be opened, we must silently ignore it because it may have
;; been removed by crontab. However, if the file is there it must be parseable,
;; otherwise the error must be propagated to the caller.
(define (read-vixie-file file-path . parse-vixie-line)
(let ((port #f))
(catch #t (lambda () (set! port (open-input-file file-path)))
(lambda (key . args) (set! port #f)))
(if port
(catch 'mcron-error
(lambda ()
(if (null? parse-vixie-line)
(read-vixie-port port)
(read-vixie-port port (car parse-vixie-line)))
(close port))
(lambda (key exit-code . msg)
(close port)
(throw 'mcron-error exit-code
(apply string-append file-path ":" msg)))))))
;; A procedure which determines if the /etc/crontab file has been recently
;; modified, and, if so, signals the main routine to re-read the file. We run
;; under the with-mail-to command so that the process runs as a child,
;; preventing lockup. If cron is supposed to check for updates to /etc/crontab,
;; then this procedure will be called about 5 seconds before every minute.
(define (check-system-crontab)
(with-mail-out (lambda ()
(let ((mtime (stat:mtime (stat "/etc/crontab"))))
(if (> mtime (- (current-time) 60))
(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
(connect socket AF_UNIX config-socket-file)
(display "/etc/crontab" socket)
(close socket)))))))

384
src/mcron/vixie-time.scm Normal file
View file

@ -0,0 +1,384 @@
;; Copyright (C) 2003 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/>.
(define-module (mcron vixie-time)
#:use-module (ice-9 regex)
#:use-module (mcron job-specifier)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-14)
#:export (parse-vixie-time))
;; In Vixie-style time specifications three-letter symbols are allowed to stand
;; for the numbers corresponding to months and days of the week. We deal with
;; this by making a textual substitution early on in the processing of the
;; strings.
;;
;; We start by defining, once and for all, a list of cons cells consisting of
;; regexps which will match the symbols - which allow an arbitrary number of
;; other letters to appear after them (so that the user can optionally complete
;; the month and day names; this is an extension of Vixie) - and the value which
;; is to replace the symbol.
;;
;; The procedure then takes a string, and then for each symbol in the
;; parse-symbols list attempts to locate an instance and replace it with an
;; ASCII representation of the value it stands for. The procedure returns the
;; modified string. (Note that each symbol can appear only once, which meets the
;; Vixie specifications technically but still allows silly users to mess things
;; up).
(define parse-symbols
(map (lambda (symbol-cell)
(cons (make-regexp (string-append (car symbol-cell) "[[:alpha:]]*")
regexp/icase)
(cdr symbol-cell)))
'(("jan" . "0") ("feb" . "1") ("mar" . "2") ("apr" . "3")
("may" . "4") ("jun" . "5") ("jul" . "6") ("aug" . "7")
("sep" . "8") ("oct" . "9") ("nov" . "10") ("dec" . "11")
("sun" . "0") ("mon" . "1") ("tue" . "2") ("wed" . "3")
("thu" . "4") ("fri" . "5") ("sat" . "6") )))
(define (vixie-substitute-parse-symbols string)
(for-each (lambda (symbol-cell)
(let ((match (regexp-exec (car symbol-cell) string)))
(if match
(set! string (string-append (match:prefix match)
(cdr symbol-cell)
(match:suffix match))))))
parse-symbols)
string)
;; A Vixie time specification is made up of a space-separated list of elements,
;; and the elements consist of a comma-separated list of subelements. The
;; procedure below takes a string holding a subelement, which should have no
;; spaces or symbols (see above) in it, and returns a list of all values which
;; that subelement indicates. There are five distinct cases which must be dealt
;; with: [1] a single '*' which returns a list of all values; [2] a '*' followed
;; by a step specifier; [3] a range and step specifier; [4] a range; and [5] a
;; single number.
;;
;; To perform the computation required for the '*' cases, we need to pass the
;; limit of the allowable range for this subelement as the third argument. As
;; days of the month start at 1 while all the other time components start at 0,
;; we must pass the base of the range to deal with this case also.
(define parse-vixie-subelement-regexp
(make-regexp "^([[:digit:]]+)(-([[:digit:]]+)(/([[:digit:]]+))?)?$"))
(define (parse-vixie-subelement string base limit)
(if (char=? (string-ref string 0) #\*)
(range base limit (if (> (string-length string) 1)
(string->number (substring string 2)) ;; [2]
1)) ;; [1]
(let ((match (regexp-exec parse-vixie-subelement-regexp string)))
(cond ((not match)
(throw 'mcron-error 9
"Bad Vixie-style time specification."))
((match:substring match 5)
(range (string->number (match:substring match 1))
(+ 1 (string->number (match:substring match 3)))
(string->number (match:substring match 5)))) ;; [3]
((match:substring match 3)
(range (string->number (match:substring match 1))
(+ 1 (string->number (match:substring match 3))))) ;; [4]
(else
(list (string->number (match:substring match 1)))))))) ;; [5]
;; A Vixie element contains the entire specification, without spaces or symbols,
;; of the acceptable values for one of the time components (minutes, hours,
;; days, months, week days). Here we break the comma-separated list into
;; subelements, and process each with the procedure above. The return value is a
;; list of all the valid values of all the subcomponents.
;;
;; The second and third arguments are the base and upper limit on the values
;; that can be accepted for this time element.
;;
;; The effect of the 'apply append' is to merge a list of lists into a single
;; list.
(define (parse-vixie-element string base limit)
(apply append
(map (lambda (sub-element)
(parse-vixie-subelement sub-element base limit))
(string-tokenize string (char-set-complement (char-set #\,))))))
;; Consider there are two lists, one of days in the month, the other of days in
;; the week. This procedure returns an augmented list of days in the month with
;; weekdays accounted for.
(define (interpolate-weekdays mday-list wday-list month year)
(let ((t (localtime 0)))
(set-tm:mday t 1)
(set-tm:mon t month)
(set-tm:year t year)
(let ((first-day (tm:wday (cdr (mktime t)))))
(apply append
mday-list
(map (lambda (wday)
(let ((first (- wday first-day)))
(if (< first 0) (set! first (+ first 7)))
(range (+ 1 first) 32 7)))
wday-list)))))
;; Return the number of days in a month. Fix up a tm object for the zero'th day
;; of the next month, rationalize the object and extract the day.
(define (days-in-month month year)
(let ((t (localtime 0))) (set-tm:mday t 0)
(set-tm:mon t (+ month 1))
(set-tm:year t year)
(tm:mday (cdr (mktime t)))))
;; We will be working with a list of time-spec's, one for each element of a time
;; specification (minute, hour, ...). Each time-spec holds three pieces of
;; information: a list of acceptable values for this time component, a procedure
;; to get the component from a tm object, and a procedure to set the component
;; in a tm object.
(define (time-spec:list time-spec) (vector-ref time-spec 0))
(define (time-spec:getter time-spec) (vector-ref time-spec 1))
(define (time-spec:setter time-spec) (vector-ref time-spec 2))
;; This procedure modifies the time tm object by setting the component referred
;; to by the time-spec object to its next acceptable value. If this value is not
;; greater than the original (because we have wrapped around the top of the
;; acceptable values list), then the function returns #t, otherwise it returns
;; #f. Thus, if the return value is true then it will be necessary for the
;; caller to increment the next coarser time component as well.
;;
;; The first part of the let block is a concession to humanity; the procedure is
;; simply unreadable without all of these aliases.
(define (increment-time-component time time-spec)
(let* ((time-list (time-spec:list time-spec))
(getter (time-spec:getter time-spec))
(setter (time-spec:setter time-spec))
(find-best-next (@@ (mcron job-specifier) %find-best-next))
(next-best (find-best-next (getter time) time-list))
(wrap-around (eqv? (cdr next-best) 9999)))
(setter time ((if wrap-around car cdr) next-best))
wrap-around))
;; There now follows a set of procedures for adjusting an element of time,
;; i.e. taking it to the next acceptable value. In each case, the head of the
;; time-spec-list is expected to correspond to the component of time in
;; question. If the adjusted value wraps around its allowed range, then the next
;; biggest element of time must be adjusted, and so on.
;; There is no specification allowed for the year component of
;; time. Therefore, if we have to make an adjustment (presumably because a
;; monthly adjustment has wrapped around the top of its range) we can simply
;; go to the next year.
(define (nudge-year! time)
(set-tm:year time (+ (tm:year time) 1)))
;; We nudge the month by finding the next allowable value, and if it wraps
;; around we also nudge the year. The time-spec-list will have time-spec
;; objects for month and weekday.
(define (nudge-month! time time-spec-list)
(and (increment-time-component time (car time-spec-list))
(nudge-year! time)))
;; Try to increment the day component of the time according to the combination
;; of the mday-list and the wday-list. If this wraps around the range, or if
;; this falls outside the current month (31st February, for example), then
;; bump the month, set the day to zero, and recurse on this procedure to find
;; the next day in the new month.
;;
;; The time-spec-list will have time-spec entries for mday, month, and
;; weekday.
(define (nudge-day! time time-spec-list)
(if (or (increment-time-component
time
(vector
(interpolate-weekdays (time-spec:list (car time-spec-list))
(time-spec:list (caddr time-spec-list))
(tm:mon time)
(tm:year time))
tm:mday
set-tm:mday))
(> (tm:mday time) (days-in-month (tm:mon time) (tm:year time))))
(begin
(nudge-month! time (cdr time-spec-list))
(set-tm:mday time 0)
(nudge-day! time time-spec-list))))
;; The hour is bumped to the next accceptable value, and the day is bumped if
;; the hour wraps around.
;;
;; The time-spec-list holds specifications for hour, mday, month and weekday.
(define (nudge-hour! time time-spec-list)
(and (increment-time-component time (car time-spec-list))
(nudge-day! time (cdr time-spec-list))))
;; The minute is bumped to the next accceptable value, and the hour is bumped
;; if the minute wraps around.
;;
;; The time-spec-list holds specifications for minute, hour, day-date, month
;; and weekday.
(define (nudge-min! time time-spec-list)
(and (increment-time-component time (car time-spec-list))
(nudge-hour! time (cdr time-spec-list))))
;; This is a procedure which returns a procedure which computes the next time a
;; command should run after the current time, based on the information in the
;; Vixie-style time specification.
;;
;; We start by computing a list of time-spec objects (described above) for the
;; minute, hour, date, month, year and weekday components of the overall time
;; specification [1]. Special care is taken to produce proper values for
;; fields 2 and 4: according to Vixie specification "If both fields are
;; restricted (ie, aren't *), the command will be run when _either_ field
;; matches the current time." This implies that if one of these fields is *,
;; while the other is not, its value should be '() [0], otherwise
;; interpolate-weekdays below will produce incorrect results.
;; When we create the return procedure, it is this list to
;; which references to a time-spec-list will be bound. It will be used by the
;; returned procedure [3] to compute the next time a function should run. Any
;; 7's in the weekday component of the list (the last one) are folded into 0's
;; (both values represent sunday) [2]. Any 0's in the month-day component of the
;; list are removed (this allows a solitary zero to be used to indicate that
;; jobs should only run on certain days of the _week_) [2.1].
;;
;; The returned procedure itself:-
;;
;; Starts by obtaining the current broken-down time [4], and fixing it to
;; ensure that it is an acceptable value, as follows. Each component from the
;; biggest down is checked for acceptability, and if it is not acceptable it
;; is bumped to the next acceptable value (this may cause higher components to
;; also be bumped if there is range wrap-around) and all the lower components
;; are set to -1 so that it can successfully be bumped up to zero if this is
;; an allowed value. The -1 value will be bumped up subsequently to an allowed
;; value [5].
;;
;; Once it has been asserted that the current time is acceptable, or has been
;; adjusted to one minute before the next acceptable time, the minute
;; component is then bumped to the next acceptable time, which may ripple
;; through the higher components if necessary [6]. We now have the next time
;; the command needs to run.
;;
;; The new time is then converted back into a UNIX time and returned [7].
(define (parse-vixie-time string)
(let ((tokens (string-tokenize (vixie-substitute-parse-symbols string))))
(cond
((> (length tokens) 5)
(throw 'mcron-error 9
"Too many fields in Vixie-style time specification"))
((< (length tokens) 5)
(throw 'mcron-error 9
"Not enough fields in Vixie-style time specification")))
(let ((time-spec-list
(map-in-order (lambda (x) (vector
(let* ((n (vector-ref x 0))
(tok (list-ref tokens n)))
(cond
((and (= n 4)
(string=? tok "*")
(not (string=?
(list-ref tokens 2) "*")))
'())
((and (= n 2)
(string=? tok "*")
(not (string=?
(list-ref tokens 4) "*")))
'())
(else
(parse-vixie-element
tok
(vector-ref x 1)
(vector-ref x 2))))) ; [0]
(vector-ref x 3)
(vector-ref x 4)))
;; token range-top+1 getter setter
`( #( 0 0 60 ,tm:min ,set-tm:min )
#( 1 0 24 ,tm:hour ,set-tm:hour )
#( 2 1 32 ,tm:mday ,set-tm:mday )
#( 3 0 12 ,tm:mon ,set-tm:mon )
#( 4 0 7 ,tm:wday ,set-tm:wday ))))) ;; [1]
(vector-set! (car (last-pair time-spec-list))
0
(map (lambda (time-spec)
(if (eqv? time-spec 7) 0 time-spec))
(vector-ref (car (last-pair time-spec-list)) 0))) ;; [2]
(vector-set! (caddr time-spec-list)
0
(remove (lambda (day) (eqv? day 0))
(vector-ref (caddr time-spec-list) 0))) ;; [2.1]
(lambda (current-time) ;; [3]
(let ((time (localtime current-time))) ;; [4]
(if (not (member (tm:mon time)
(time-spec:list (cadddr time-spec-list))))
(begin
(nudge-month! time (cdddr time-spec-list))
(set-tm:mday time 0)))
(if (or (eqv? (tm:mday time) 0)
(not (member (tm:mday time)
(interpolate-weekdays
(time-spec:list (caddr time-spec-list))
(time-spec:list (caddr (cddr time-spec-list)))
(tm:mon time)
(tm:year time)))))
(begin
(nudge-day! time (cddr time-spec-list))
(set-tm:hour time -1)))
(if (not (member (tm:hour time)
(time-spec:list (cadr time-spec-list))))
(begin
(nudge-hour! time (cdr time-spec-list))
(set-tm:min time -1))) ;; [5]
(set-tm:sec time 0)
(nudge-min! time time-spec-list) ;; [6]
(car (mktime time))))))) ;; [7]