diff options
Diffstat (limited to 'scm/mcron/redirect.scm')
| -rw-r--r-- | scm/mcron/redirect.scm | 189 |
1 files changed, 189 insertions, 0 deletions
diff --git a/scm/mcron/redirect.scm b/scm/mcron/redirect.scm new file mode 100644 index 0000000..312b768 --- /dev/null +++ b/scm/mcron/redirect.scm @@ -0,0 +1,189 @@ +;; 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 ((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))) |