Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 311 lines (268 sloc) 9.269 kb
fe4213e add copyright
layer authored
1 ;; copyright (C) 2003 Franz Inc, Oakland, CA - All rights reserved.
2 ;;
3 ;; The software, data and information contained herein are proprietary
4 ;; to, and comprise valuable trade secrets of, Franz, Inc. They are
5 ;; given in confidence by Franz, Inc. pursuant to a written license
6 ;; agreement, and may be stored and used only in accordance with the terms
7 ;; of such license.
8 ;;
9 ;; Restricted Rights Legend
10 ;; ------------------------
11 ;; Use, duplication, and disclosure of the software, data and information
12 ;; contained herein by any agency, department or entity of the U.S.
13 ;; Government are subject to restrictions of Restricted Rights for
14 ;; Commercial Software developed at private expense as specified in
15 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
16 ;;
3540408 see ChangeLog
dancy authored
17 ;; $Id: input.cl,v 1.17 2007/05/30 14:09:22 dancy Exp $
1f8e619 2003-07-08 Kevin Layer <layer@relay.known.net>
layer authored
18
eceb085 First revision
dancy authored
19 (in-package :user)
20
21 (defun trusted-user-p (us)
22 (member us *trusted-users* :test #'equalp))
23
24 ;; returns (values parsed-from-address from-name real-user)
25 (defun compute-sender-info (user-fromaddr user-gecos)
26 (let* ((uid (getuid)) ;; the real uid
27 (pwent (getpwuid uid))
28 (auth-warn t)
29 gecos parsedfromaddr )
30 (if (null pwent)
31 (error "I can't figure out who you are! (uid=~D)" uid))
32
33 ;; It is okay for gecos to end up being nil. This means
34 ;; that no human-friendly name will be in the From:
35 ;; header.
36 (if* (null user-fromaddr)
37 then
38 (setf user-fromaddr (pwent-name pwent))
39 (setf gecos (pwent-gecos pwent))
40 (setf auth-warn nil))
41
42 (setf parsedfromaddr
43 (parse-email-addr user-fromaddr :allow-null t))
44 (if (null parsedfromaddr)
45 (error "~A is not a valid address" user-fromaddr))
46
47 ;; don't need to look up gecos info if the fromaddr
48 ;; is not local.. or if user-gecos is specified.
49 (if (and (local-domain-p parsedfromaddr) (null user-gecos))
80e243e see ChangeLog
dancy authored
50 (let ((newpwent
51 (getpwnam (string-downcase (emailaddr-user parsedfromaddr)))))
eceb085 First revision
dancy authored
52 (if* newpwent
53 then
54 (setf gecos (pwent-gecos newpwent))
55 (if (string= (pwent-name pwent) (pwent-name newpwent))
56 (setf auth-warn nil)))))
57
58 (if user-gecos
59 (setf gecos user-gecos))
60
61 (values
62 parsedfromaddr
63 gecos
64 (if (trusted-user-p (pwent-name pwent))
65 nil
66 auth-warn)
67 (pwent-name pwent))))
68
69
8a4d253 see ChangeLog
dancy authored
70 ;; 'recips' is a (possibly empty) list of recip structs
c74ecfb see ChangeLog
dancy authored
71 (defun send-from-stdin (recips &key (dot t) gecos from verbose
72 grab-recips metoo)
eceb085 First revision
dancy authored
73 (multiple-value-bind (fromaddr gecos authwarn realuser)
74 (compute-sender-info from gecos)
80e243e see ChangeLog
dancy authored
75 (let (q errstatus)
cbd98fe see ChangeLog
dancy authored
76 (with-new-queue (q f errstatus fromaddr *localhost*)
80e243e see ChangeLog
dancy authored
77 ;; body doesn't execute if datafile open failed.
a2752fd v1.2.18. Changes to handle SIZE client/server extension and keep size o...
Ahmon Dancy authored
78 (multiple-value-bind (status headers complaint err-string smtp-size)
80e243e see ChangeLog
dancy authored
79 (read-message-stream *standard-input* f :dot dot)
a2752fd v1.2.18. Changes to handle SIZE client/server extension and keep size o...
Ahmon Dancy authored
80 (declare (ignore err-string))
80e243e see ChangeLog
dancy authored
81 (if (not (member status '(:eof :dot)))
82 (error "got status ~s from read-message-stream" status))
3540408 see ChangeLog
dancy authored
83
84 (if complaint
85 (error "~a" complaint))
80e243e see ChangeLog
dancy authored
86
9be964d See ChangeLog
dancy authored
87 (if grab-recips
88 (setf recips
89 (append recips (grab-recips-from-headers headers))))
90
8a4d253 see ChangeLog
dancy authored
91 (if (null recips)
92 (error "No recipient addresses found in header"))
93
80e243e see ChangeLog
dancy authored
94 (if authwarn
95 (setf headers
96 (append headers
97 (list (make-x-auth-warning-header realuser fromaddr)))))
a2752fd v1.2.18. Changes to handle SIZE client/server extension and keep size o...
Ahmon Dancy authored
98 (queue-prefinalize q recips headers
99 :metoo metoo
100 :smtp-size smtp-size)
cbd98fe see ChangeLog
dancy authored
101
11afacb See ChangeLog.
dancy authored
102 ;; Run message checkers.
1935ba9 See ChangeLog
dancy authored
103 (multiple-value-bind (res text checker)
cbd98fe see ChangeLog
dancy authored
104 (check-message-checkers q)
1935ba9 See ChangeLog
dancy authored
105 (declare (ignore checker))
106 (ecase res
107 (:ok
108 ) ;; all is well
109 ((:transient :reject)
110 (error "Message rejected: ~A" text))))
111
80e243e see ChangeLog
dancy authored
112
113 ;; This marks the message as complete.
cbd98fe see ChangeLog
dancy authored
114 (queue-finalize q recips headers
115 :date t
116 :add-from t
117 :from-gecos gecos
118 :metoo metoo)))
80e243e see ChangeLog
dancy authored
119
120 (when errstatus
121 ;; somethin' went wrong. It should already have been logged.
122 ;; Report it to the user and bail out.
123 (error (second errstatus)))
e8d06eb See ChangeLog
dancy authored
124
eceb085 First revision
dancy authored
125 ;; XXX -- this might need changing.
126 ;; I think sendmail goes through and processes local recips
127 ;; and returns immediate errors (dead.letter).. then forks
128 ;; to handle the rest.. which may potentially be slower.
129 ;; For now, we're going to fork for any type of message.
80e243e see ChangeLog
dancy authored
130
131 ;; Verbosity implies no fork.
132 (let ((pid (if (or verbose *debug*) 0 (fork))))
e8d06eb See ChangeLog
dancy authored
133 (if* (= pid 0)
134 then
80e243e see ChangeLog
dancy authored
135 (if (and (not *debug*) (not verbose))
e8d06eb See ChangeLog
dancy authored
136 (detach-from-terminal))
80e243e see ChangeLog
dancy authored
137 (queue-process-single (queue-id q) :wait t :verbose t))))))
9be964d See ChangeLog
dancy authored
138
d081945 Fixed folded header issue in grab-recips-from-headers
dancy authored
139 ;; Works right even if there are multiple To:, Cc: or Bcc: headers.
140 ;; Works on folded headers now too.
9be964d See ChangeLog
dancy authored
141 (defun grab-recips-from-headers (headers)
d081945 Fixed folded header issue in grab-recips-from-headers
dancy authored
142 (let (good-recips pos h nextline)
143 (while headers
144 (setf h (pop headers))
145 (when (recip-header-p h)
146 (while (setf nextline (pop headers))
147 (if (or (= 0 (length nextline))
148 (not (whitespace-p (schar nextline 0))))
149 (return)) ;; break
150 (setf h (header-unfold h nextline)))
151 ;; get here if nextline wasn't there.. or if it was
152 ;; the beginning of a new header
153 (if nextline
154 (push nextline headers))
155
156 (setf pos (recip-header-p h))
157 (when pos
158 (setf good-recips
159 (nconc good-recips
160 (get-good-recips-from-string h :pos pos))))))
8a4d253 see ChangeLog
dancy authored
161 good-recips))
eceb085 First revision
dancy authored
162
3540408 see ChangeLog
dancy authored
163 (defmacro msg-too-large-p (count)
164 `(and *maxmsgsize* (> *maxmsgsize* 0) (> ,count *maxmsgsize*)))
165
166 ;; called from send-from-stdin, smtp-data
eceb085 First revision
dancy authored
167 (defun read-message-stream (s bodystream &key smtp dot)
3540408 see ChangeLog
dancy authored
168 (multiple-value-prog1
169 (read-message-stream-inner s bodystream :smtp smtp :dot dot)
80e243e see ChangeLog
dancy authored
170 (finish-output bodystream)
3540408 see ChangeLog
dancy authored
171 (fsync bodystream))) ;; Try to make sure the data file is really on disk.
80e243e see ChangeLog
dancy authored
172
173
3540408 see ChangeLog
dancy authored
174 ;; Returns:
175 ;; Termination reason (:eof or :dot)
176 ;; List of header lines
177 ;; Error keyword (or nil)
178 ;; Error string (or nil)
a2752fd v1.2.18. Changes to handle SIZE client/server extension and keep size o...
Ahmon Dancy authored
179 ;; (Over)estimated message size (As it would be transmitted via SMTP).
80e243e see ChangeLog
dancy authored
180 (defun read-message-stream-inner (s bodystream &key smtp dot)
eceb085 First revision
dancy authored
181 (let ((count 0)
a2752fd v1.2.18. Changes to handle SIZE client/server extension and keep size o...
Ahmon Dancy authored
182 (size 0)
eceb085 First revision
dancy authored
183 (doingheaders t)
184 (firstline t)
185 (buffer (make-string *maxdatalinelen*))
186 lastincomplete
3540408 see ChangeLog
dancy authored
187 headers
188 headers-too-big)
eceb085 First revision
dancy authored
189 (if smtp
190 (setf dot t))
191 (loop
192 (multiple-value-bind (endpos maxed)
193 (read-message-stream-line s buffer
194 :timeout (if smtp *datatimeout*))
195
3540408 see ChangeLog
dancy authored
196 (when (or (eq endpos :eof) (and dot
197 (not lastincomplete)
198 (= endpos 1)
199 (char= (schar buffer 0) #\.)
200 (setf endpos :dot)))
201 (if* headers-too-big
202 then (return
203 (values
204 endpos
205 nil
206 (format nil "Headers too large (~d max)" *maxheadersize*)))
207 elseif (msg-too-large-p count)
208 then (return
209 (values
210 endpos
211 nil
212 (format nil "Message exceeds maximum fixed size (~D)"
213 *maxmsgsize*)))
a2752fd v1.2.18. Changes to handle SIZE client/server extension and keep size o...
Ahmon Dancy authored
214 else (return
215 (values endpos (nreverse headers) nil nil size))))
3540408 see ChangeLog
dancy authored
216
eceb085 First revision
dancy authored
217 (incf count endpos)
a2752fd v1.2.18. Changes to handle SIZE client/server extension and keep size o...
Ahmon Dancy authored
218 (incf size (+ endpos 2)) ;; +2 to account for CR/LF
eceb085 First revision
dancy authored
219
220 (if* doingheaders
3540408 see ChangeLog
dancy authored
221 then
eceb085 First revision
dancy authored
222 (cond
00d39c2 See ChangeLog
dancy authored
223 ;; Special case. Messages that begin w/ a Unix
224 ;; mailbox "From " separator have the separator
225 ;; stripped.
3540408 see ChangeLog
dancy authored
226 ((and firstline (match-re "^From " buffer :end endpos))
00d39c2 See ChangeLog
dancy authored
227 ;; Just ignore it
228 )
eceb085 First revision
dancy authored
229 ((and firstline
230 (not (valid-header-line-p buffer endpos :strict t)))
231 (setf doingheaders nil)
232 (read-message-stream-write-body
233 bodystream buffer endpos count
234 :nonewline maxed
235 :smtp smtp))
3540408 see ChangeLog
dancy authored
236 (lastincomplete
237 (if (not headers-too-big)
238 (push (concatenate 'string
239 (pop headers) (subseq buffer 0 endpos))
240 headers)))
eceb085 First revision
dancy authored
241 ((= endpos 0) ;; blank line
242 (setf doingheaders nil)
243 (if (null headers)
244 (write-char #\newline bodystream)))
245 ((valid-header-line-p buffer endpos)
3540408 see ChangeLog
dancy authored
246 (if (not headers-too-big)
247 (push (subseq buffer 0 endpos) headers)))
eceb085 First revision
dancy authored
248 (t ;; non-header
249 (setf doingheaders nil)
250 (read-message-stream-write-body
251 bodystream buffer endpos count
252 :nonewline maxed
253 :smtp smtp)))
254
255 (setf firstline nil)
3540408 see ChangeLog
dancy authored
256
257 (if (> count *maxheadersize*)
258 (setf headers-too-big t))
eceb085 First revision
dancy authored
259 else
260 ;; doing body.
261 (read-message-stream-write-body
262 bodystream buffer endpos count
263 :nonewline maxed
264 :smtp smtp))
265
266 (setf lastincomplete maxed)))))
267
268
269 (defun read-message-stream-write-body (s buffer endpos count
270 &key nonewline smtp)
3540408 see ChangeLog
dancy authored
271 (when (not (msg-too-large-p count))
272 (write-string
273 buffer s
274 :start (if* (and smtp (match-re "^\\.\\." buffer :end endpos))
275 then 1
276 else 0)
277 :end endpos)
eceb085 First revision
dancy authored
278 (if (null nonewline)
279 (write-char #\newline s))))
280
281
282 (defun read-message-stream-line (s buffer &key timeout)
75fd0c1 see changelog
dancy authored
283 (with-socket-timeout (s :read timeout)
eceb085 First revision
dancy authored
284 (read-message-stream-line-inner s buffer)))
285
286
287 (defun read-message-stream-line-inner (s buffer)
288 (let ((pos 0)
289 (max (length buffer))
290 lastchar
291 char)
292 (loop
293 (when (>= pos max)
294 (unread-char lastchar s)
295 (return (values (1- pos) :max)))
296
297 (setf char (read-char s nil nil))
298
299 ;;; if we're in the middle of a line, treat EOF as EOL
300 (if (null char)
301 (return (if (= pos 0) :eof pos)))
302
303 (when (eq char #\linefeed)
304 (if (and (eq lastchar #\return) (> pos 0))
305 (decf pos))
306 (return pos))
307
308 (setf (schar buffer pos) char)
309 (setf lastchar char)
310 (incf pos))))
Something went wrong with that request. Please try again.