Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 310 lines (268 sloc) 9.269 kb
fe4213e4 » layer
2003-07-08 add copyright
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 ;;
35404085 » dancy
2007-05-30 see ChangeLog
17 ;; $Id: input.cl,v 1.17 2007/05/30 14:09:22 dancy Exp $
1f8e6194 » layer
2003-07-08 2003-07-08 Kevin Layer <layer@relay.known.net>
18
eceb0852 » dancy
2003-04-23 First revision
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))
80e243ef » dancy
2003-05-01 see ChangeLog
50 (let ((newpwent
51 (getpwnam (string-downcase (emailaddr-user parsedfromaddr)))))
eceb0852 » dancy
2003-04-23 First revision
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
8a4d2531 » dancy
2003-05-15 see ChangeLog
70 ;; 'recips' is a (possibly empty) list of recip structs
c74ecfb4 » dancy
2003-07-08 see ChangeLog
71 (defun send-from-stdin (recips &key (dot t) gecos from verbose
72 grab-recips metoo)
eceb0852 » dancy
2003-04-23 First revision
73 (multiple-value-bind (fromaddr gecos authwarn realuser)
74 (compute-sender-info from gecos)
80e243ef » dancy
2003-05-01 see ChangeLog
75 (let (q errstatus)
cbd98fe9 » dancy
2006-11-14 see ChangeLog
76 (with-new-queue (q f errstatus fromaddr *localhost*)
80e243ef » dancy
2003-05-01 see ChangeLog
77 ;; body doesn't execute if datafile open failed.
a2752fd3 » Ahmon Dancy
2009-05-06 v1.2.18. Changes to handle SIZE client/server extension and keep size…
78 (multiple-value-bind (status headers complaint err-string smtp-size)
80e243ef » dancy
2003-05-01 see ChangeLog
79 (read-message-stream *standard-input* f :dot dot)
a2752fd3 » Ahmon Dancy
2009-05-06 v1.2.18. Changes to handle SIZE client/server extension and keep size…
80 (declare (ignore err-string))
80e243ef » dancy
2003-05-01 see ChangeLog
81 (if (not (member status '(:eof :dot)))
82 (error "got status ~s from read-message-stream" status))
35404085 » dancy
2007-05-30 see ChangeLog
83
84 (if complaint
85 (error "~a" complaint))
80e243ef » dancy
2003-05-01 see ChangeLog
86
9be964d1 » dancy
2003-05-09 See ChangeLog
87 (if grab-recips
88 (setf recips
89 (append recips (grab-recips-from-headers headers))))
90
8a4d2531 » dancy
2003-05-15 see ChangeLog
91 (if (null recips)
92 (error "No recipient addresses found in header"))
93
80e243ef » dancy
2003-05-01 see ChangeLog
94 (if authwarn
95 (setf headers
96 (append headers
97 (list (make-x-auth-warning-header realuser fromaddr)))))
a2752fd3 » Ahmon Dancy
2009-05-06 v1.2.18. Changes to handle SIZE client/server extension and keep size…
98 (queue-prefinalize q recips headers
99 :metoo metoo
100 :smtp-size smtp-size)
cbd98fe9 » dancy
2006-11-14 see ChangeLog
101
11afacb1 » dancy
2005-06-13 See ChangeLog.
102 ;; Run message checkers.
1935ba96 » dancy
2003-05-19 See ChangeLog
103 (multiple-value-bind (res text checker)
cbd98fe9 » dancy
2006-11-14 see ChangeLog
104 (check-message-checkers q)
1935ba96 » dancy
2003-05-19 See ChangeLog
105 (declare (ignore checker))
106 (ecase res
107 (:ok
108 ) ;; all is well
109 ((:transient :reject)
110 (error "Message rejected: ~A" text))))
111
80e243ef » dancy
2003-05-01 see ChangeLog
112
113 ;; This marks the message as complete.
cbd98fe9 » dancy
2006-11-14 see ChangeLog
114 (queue-finalize q recips headers
115 :date t
116 :add-from t
117 :from-gecos gecos
118 :metoo metoo)))
80e243ef » dancy
2003-05-01 see ChangeLog
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)))
e8d06eb0 » dancy
2003-04-30 See ChangeLog
124
eceb0852 » dancy
2003-04-23 First revision
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.
80e243ef » dancy
2003-05-01 see ChangeLog
130
131 ;; Verbosity implies no fork.
132 (let ((pid (if (or verbose *debug*) 0 (fork))))
e8d06eb0 » dancy
2003-04-30 See ChangeLog
133 (if* (= pid 0)
134 then
80e243ef » dancy
2003-05-01 see ChangeLog
135 (if (and (not *debug*) (not verbose))
e8d06eb0 » dancy
2003-04-30 See ChangeLog
136 (detach-from-terminal))
80e243ef » dancy
2003-05-01 see ChangeLog
137 (queue-process-single (queue-id q) :wait t :verbose t))))))
9be964d1 » dancy
2003-05-09 See ChangeLog
138
d081945f » dancy
2003-06-28 Fixed folded header issue in grab-recips-from-headers
139 ;; Works right even if there are multiple To:, Cc: or Bcc: headers.
140 ;; Works on folded headers now too.
9be964d1 » dancy
2003-05-09 See ChangeLog
141 (defun grab-recips-from-headers (headers)
d081945f » dancy
2003-06-28 Fixed folded header issue in grab-recips-from-headers
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))))))
8a4d2531 » dancy
2003-05-15 see ChangeLog
161 good-recips))
eceb0852 » dancy
2003-04-23 First revision
162
35404085 » dancy
2007-05-30 see ChangeLog
163 (defmacro msg-too-large-p (count)
164 `(and *maxmsgsize* (> *maxmsgsize* 0) (> ,count *maxmsgsize*)))
165
166 ;; called from send-from-stdin, smtp-data
eceb0852 » dancy
2003-04-23 First revision
167 (defun read-message-stream (s bodystream &key smtp dot)
35404085 » dancy
2007-05-30 see ChangeLog
168 (multiple-value-prog1
169 (read-message-stream-inner s bodystream :smtp smtp :dot dot)
80e243ef » dancy
2003-05-01 see ChangeLog
170 (finish-output bodystream)
35404085 » dancy
2007-05-30 see ChangeLog
171 (fsync bodystream))) ;; Try to make sure the data file is really on disk.
80e243ef » dancy
2003-05-01 see ChangeLog
172
173
35404085 » dancy
2007-05-30 see ChangeLog
174 ;; Returns:
175 ;; Termination reason (:eof or :dot)
176 ;; List of header lines
177 ;; Error keyword (or nil)
178 ;; Error string (or nil)
a2752fd3 » Ahmon Dancy
2009-05-06 v1.2.18. Changes to handle SIZE client/server extension and keep size…
179 ;; (Over)estimated message size (As it would be transmitted via SMTP).
80e243ef » dancy
2003-05-01 see ChangeLog
180 (defun read-message-stream-inner (s bodystream &key smtp dot)
eceb0852 » dancy
2003-04-23 First revision
181 (let ((count 0)
a2752fd3 » Ahmon Dancy
2009-05-06 v1.2.18. Changes to handle SIZE client/server extension and keep size…
182 (size 0)
eceb0852 » dancy
2003-04-23 First revision
183 (doingheaders t)
184 (firstline t)
185 (buffer (make-string *maxdatalinelen*))
186 lastincomplete
35404085 » dancy
2007-05-30 see ChangeLog
187 headers
188 headers-too-big)
eceb0852 » dancy
2003-04-23 First revision
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
35404085 » dancy
2007-05-30 see ChangeLog
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*)))
a2752fd3 » Ahmon Dancy
2009-05-06 v1.2.18. Changes to handle SIZE client/server extension and keep size…
214 else (return
215 (values endpos (nreverse headers) nil nil size))))
35404085 » dancy
2007-05-30 see ChangeLog
216
eceb0852 » dancy
2003-04-23 First revision
217 (incf count endpos)
a2752fd3 » Ahmon Dancy
2009-05-06 v1.2.18. Changes to handle SIZE client/server extension and keep size…
218 (incf size (+ endpos 2)) ;; +2 to account for CR/LF
eceb0852 » dancy
2003-04-23 First revision
219
220 (if* doingheaders
35404085 » dancy
2007-05-30 see ChangeLog
221 then
eceb0852 » dancy
2003-04-23 First revision
222 (cond
00d39c22 » dancy
2003-06-30 See ChangeLog
223 ;; Special case. Messages that begin w/ a Unix
224 ;; mailbox "From " separator have the separator
225 ;; stripped.
35404085 » dancy
2007-05-30 see ChangeLog
226 ((and firstline (match-re "^From " buffer :end endpos))
00d39c22 » dancy
2003-06-30 See ChangeLog
227 ;; Just ignore it
228 )
eceb0852 » dancy
2003-04-23 First revision
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))
35404085 » dancy
2007-05-30 see ChangeLog
236 (lastincomplete
237 (if (not headers-too-big)
238 (push (concatenate 'string
239 (pop headers) (subseq buffer 0 endpos))
240 headers)))
eceb0852 » dancy
2003-04-23 First revision
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)
35404085 » dancy
2007-05-30 see ChangeLog
246 (if (not headers-too-big)
247 (push (subseq buffer 0 endpos) headers)))
eceb0852 » dancy
2003-04-23 First revision
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)
35404085 » dancy
2007-05-30 see ChangeLog
256
257 (if (> count *maxheadersize*)
258 (setf headers-too-big t))
eceb0852 » dancy
2003-04-23 First revision
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)
35404085 » dancy
2007-05-30 see ChangeLog
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)
eceb0852 » dancy
2003-04-23 First revision
278 (if (null nonewline)
279 (write-char #\newline s))))
280
281
282 (defun read-message-stream-line (s buffer &key timeout)
75fd0c14 » dancy
2003-04-25 see changelog
283 (with-socket-timeout (s :read timeout)
eceb0852 » dancy
2003-04-23 First revision
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.