diff options
Diffstat (limited to 'src/mcron/base.scm')
| -rw-r--r-- | src/mcron/base.scm | 247 |
1 files changed, 247 insertions, 0 deletions
diff --git a/src/mcron/base.scm b/src/mcron/base.scm new file mode 100644 index 0000000..c100b4f --- /dev/null +++ b/src/mcron/base.scm @@ -0,0 +1,247 @@ +;;;; base.scm -- core procedures +;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net> +;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> +;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 base) + #:use-module (ice-9 match) + #:use-module (mcron environment) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-9) + #:export (add-job + remove-user-jobs + get-schedule + run-job-loop + ;; Deprecated and undocumented procedures. + use-system-job-list + use-user-job-list + clear-system-jobs) + #:re-export (clear-environment-mods + append-environment-mods)) + +;; 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))))) + +(define (find-next-jobs) + "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." + (let loop ((jobs (append system-job-list user-job-list)) + (next-time (inf)) + (next-jobs '())) + (match jobs + (() + (cons (and (finite? next-time) next-time) next-jobs)) + ((job . rest) + (let ((this-time (job:next-time job))) + (cond ((< this-time next-time) + (loop rest this-time (list job))) + ((= this-time next-time) + (loop rest next-time (cons job next-jobs))) + (else + (loop rest next-time next-jobs)))))))) + +;; 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) + (dynamic-wind + (const #t) + (lambda () + (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))) + (lambda () + (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)))) + +(define* (run-job-loop #:optional fd-list) + ;; 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). + (call-with-current-continuation + (lambda (break) + (let loop () + (match (find-next-jobs) + ((next-time . next-jobs-lst) + (let ((sleep-time (if next-time + (- next-time (current-time)) + 2000000000))) + (when (and + (> sleep-time 0) + (not (null? (catch 'system-error + (λ () + (car (select fd-list '() '() sleep-time))) + (λ (key . args) + (let ((err (car (last args)))) + (cond ((member err (list EINTR EAGAIN)) + (child-cleanup) + '()) + (else + (apply throw key args))))))))) + (break)) + (run-jobs next-jobs-lst) + (child-cleanup) + (loop)))))))) |