189 lines
7.5 KiB
Scheme
189 lines
7.5 KiB
Scheme
;; 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)))
|