Merge branch 'devel'

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))))))))