1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
|
;;;; redirect.scm -- modify job outputs
;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net>
;;; Copyright © 2018 宋文武 <iyzsong@member.fsf.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/>.
;;;; Commentary:
;;;
;;; Provide 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.
;;;
;;;; Code:
(define-module (mcron redirect)
#:use-module (ice-9 popen)
#:use-module (ice-9 regex)
#:use-module (mcron config)
#:use-module (mcron vixie-time)
#:export (with-mail-out))
;; 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.
(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")
;; The sendmail command should read
;; recipients from the message header.
(open-output-pipe config-sendmail)))
(set-current-input-port (car child->parent))
(display "To: ") (display user) (newline)
(display "From: GNU 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)))
|
