1 ;; -*- mode: common-lisp; package: net.post-office -*-
5 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
7 ;; This code is free software; you can redistribute it and/or
8 ;; modify it under the terms of the version 2.1 of
9 ;; the GNU Lesser General Public License as published by
10 ;; the Free Software Foundation, as clarified by the AllegroServe
11 ;; prequel found in license-allegroserve.txt.
13 ;; This code is distributed in the hope that it will be useful,
14 ;; but without any warranty; without even the implied warranty of
15 ;; merchantability or fitness for a particular purpose. See the GNU
16 ;; Lesser General Public License for more details.
18 ;; Version 2.1 of the GNU Lesser General Public License is in the file
19 ;; license-lgpl.txt that was distributed with this file.
20 ;; If it is not present, you can access it from
21 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
22 ;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
23 ;; Suite 330, Boston, MA 02111-1307 USA
26 ;; $Id: smtp.cl,v 1.1 2002/10/09 14:26:11 kevin Exp $
29 ;; send mail to an smtp server. See rfc821 for the spec.
31 ;;- This code in this file obeys the Lisp Coding Standard found in
32 ;;- http://www.franz.com/~jkf/coding_standards.html
36 (defpackage :net.post-office
41 #:test-email-address))
43 (in-package :net.post-office)
46 ;; the exported functions:
48 ;; (send-letter "mail-server" "from" "to" "message"
49 ;; &key cc bcc subject reply-to headers)
52 ;; sends a message to the mail server (which may be a relay server
53 ;; or the final destination). "from" is the address to be given
54 ;; as the sender. "to" can be a string or a list of strings naming
56 ;; "message" is the message to be sent
57 ;; cc and bcc can be either be a string or a list of strings
58 ;; naming recipients. All cc's and bcc's are sent the message
59 ;; but the bcc's aren't included in the header created.
60 ;; reply-to's value is a string and in cases a Reply-To header
62 ;; headers is a string or list of stings. These are raw header lines
63 ;; added to the header build to send out.
65 ;; This builds a header and inserts the optional cc, bcc,
66 ;; subject and reply-to lines.
68 ;; (send-smtp "mail-server" "from" "to" &rest messages)
69 ;; this is like send-letter except that it doesn't build a header.
70 ;; the messages should contain a header (and if not then sendmail
71 ;; notices this and builds one -- other MTAs may not be that smart).
72 ;; The messages ia list of strings to be concatenated together
73 ;; and sent as one message
76 ;; (test-email-address "user@machine.com")
77 ;; return t is this could be a valid email address on the machine
78 ;; named. Do this by contacting the mail server and using the VRFY
79 ;; command from smtp. Since some mail servers don't implement VRFY
80 ;; we return t if VRFY doesn't work.
81 ;; nil means that this address is bad (or we can't make contact with
82 ;; the mail server, which could of course be a transient problem).
89 (defmacro response-case ((smtp-stream &optional smtp-response response-code) &rest case-clauses)
90 ;; get a response from the smtp server and dispatch in a 'case' like
91 ;; fashion to a clause based on the first digit of the return
92 ;; code of the response.
93 ;; smtp-response, if given, will be bound to string that is
94 ;; the actual response
96 (let ((response-class (gensym)))
97 `(multiple-value-bind (,response-class
98 ,@(if* smtp-response then (list smtp-response))
99 ,@(if* response-code then (list response-code)))
100 (progn (force-output ,smtp-stream)
101 (wait-for-response ,smtp-stream))
102 ;;(declare (ignorable smtp-response))
103 (case ,response-class
106 (defvar *smtp-debug* nil)
110 (defun send-letter (server from to message
111 &key cc bcc subject reply-to headers)
113 ;; see documentation at the head of this file
115 (let ((header (make-string-output-stream))
116 (tos (if* (stringp to)
120 else (error "to should be a string or list, not ~s" to)))
128 else (error "cc should be a string or list, not ~s" cc)))
129 (bccs (if* (null bcc)
135 else (error "bcc should be a string or list, not ~s" bcc))))
136 (format header "From: ~a~c~cTo: "
140 (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed)
142 then (format header "Cc: ~{ ~a~^,~}~c~c" ccs #\return #\linefeed))
145 then (format header "Subject: ~a~c~c" subject #\return #\linefeed))
148 then (format header "Reply-To: ~a~c~c" reply-to #\return #\linefeed))
151 then (if* (stringp headers)
152 then (setq headers (list headers))
153 elseif (consp headers)
155 else (error "Unknown headers format: ~s." headers))
157 (format header "~a~c~c" h #\return #\linefeed)))
159 (format header "~c~c" #\return #\linefeed)
161 (send-smtp server from (append tos ccs bccs)
162 (get-output-stream-string header)
169 (defun send-smtp (server from to &rest messages)
170 ;; send the effective concatenation of the messages via
171 ;; smtp to the mail server
172 ;; Each message should be a string
174 ;; 'to' can be a single string or a list of strings.
175 ;; each string should be in the official rfc822 format "foo@bar.com"
178 (let ((sock (connect-to-mail-server server)))
183 (smtp-command sock "MAIL from:<~a>" from)
184 (response-case (sock msg)
188 (t (error "Mail from command failed: ~s" msg)))
190 (let ((tos (if* (stringp to)
194 else (error "to should be a string or list, not ~s"
197 (smtp-command sock "RCPT to:<~a>" to)
198 (response-case (sock msg)
202 (t (error "rcpt to command failed: ~s" msg)))))
204 (smtp-command sock "DATA")
205 (response-case (sock msg)
208 (t (error "Data command failed: ~s" msg)))
214 (dolist (message messages)
215 (dotimes (i (length message))
216 (let ((ch (aref message i)))
217 (if* (and at-bol (eq ch #\.))
218 then ; to prevent . from being interpreted as eol
219 (write-char #\. sock))
220 (if* (eq ch #\newline)
222 (if* (not (eq prev-ch #\return))
223 then (write-char #\return sock))
224 else (setq at-bol nil))
226 (setq prev-ch ch)))))
228 (write-char #\return sock) (write-char #\linefeed sock)
229 (write-char #\. sock)
230 (write-char #\return sock) (write-char #\linefeed sock)
232 (response-case (sock msg)
233 (2 nil ; (format t "Message sent to ~a~%" to)
236 (t (error "message not sent: ~s" msg)))
240 (smtp-command sock "QUIT")
241 (response-case (sock msg)
244 (t (error "quit failed: ~s" msg))))
247 (defun connect-to-mail-server (server)
248 ;; make that initial connection to the mail server
249 ;; returning a socket connected to it and
250 ;; signaling an error if it can't be made.
251 (let ((ipaddr (determine-mail-server server))
256 then (error "Can't determine ip addres for mail server ~s" server))
258 (setq sock (socket:make-socket :remote-host ipaddr
259 :remote-port 25 ; smtp
263 (response-case (sock msg)
264 (2 ;; to the initial connect
266 (t (error "initial connect failed: ~s" msg)))
268 ;; now that we're connected we can compute our hostname
269 (let ((hostname (socket:ipaddr-to-hostname
270 (socket:local-host sock))))
273 (format nil "[~a]" (socket:ipaddr-to-dotted
274 (socket:local-host sock)))))
275 (smtp-command sock "HELO ~a" hostname)
276 (response-case (sock msg)
279 (t (error "hello greeting failed: ~s" msg))))
286 then (close sock :abort t)
295 (defun test-email-address (address)
296 ;; test to see if we can determine if the address is valid
297 ;; return nil if the address is bogus
298 ;; return t if the address may or may not be bogus
299 (if* (or (not (stringp address))
300 (zerop (length address)))
301 then (error "mail address should be a non-empty string: ~s" address))
303 ; split on the @ sign
305 (let ((pos (position #\@ address)))
307 then (setq name address
308 hostname "localhost")
309 elseif (or (eql pos 0)
310 (eql pos (1- (length address))))
311 then ; @ at beginning or end, bogus since we don't do route addrs
312 (return-from test-email-address nil)
313 else (setq name (subseq address 0 pos)
314 hostname (subseq address (1+ pos)))))
316 (let ((sock (ignore-errors (connect-to-mail-server hostname))))
317 (if* (null sock) then (return-from test-email-address nil))
321 (smtp-command sock "VRFY ~a" name)
322 (response-case (sock msg code)
326 msg ; to remove unused warning
328 else t ; otherwise we don't know
331 (close sock :abort t)))))
347 (defun wait-for-response (stream)
348 ;; read the response of the smtp server.
349 ;; collect it all in a string.
350 ;; Return two values:
353 ;; The string should begin with a decimal digit, and that is converted
354 ;; into a number which is returned as the response class.
355 ;; If the string doesn't begin with a decimal digit then the
356 ;; response class is -1.
358 (flet ((match-chars (string pos1 pos2 count)
361 (if* (not (eq (aref string (+ pos1 i))
362 (aref string (+ pos2 i))))
363 then (return nil)))))
365 (let ((res (make-array 20 :element-type 'character
368 (if* (null (read-a-line stream res))
369 then ; eof encountered before end of line
370 (return-from wait-for-response (values -1 res)))
372 ;; a multi-line response begins with line containing
373 ;; a hyphen in the 4th column:
376 ;; and ends with a line containing the same reply code but no
381 (if* (and (>= (length res) 4) (eq #\- (aref res 3)))
382 then ;; multi line response
383 (let ((old-length (length res))
386 (if* (null (read-a-line stream res))
387 then ; eof encountered before end of line
388 (return-from wait-for-response (values -1 res)))
389 (setq new-length (length res))
390 ;; see if this is the last line
391 (if* (and (>= (- new-length old-length) 4)
392 (eq (aref res (+ old-length 3)) #\space)
393 (match-chars res 0 old-length 3))
396 (setq old-length new-length))))
398 ;; complete response is in res
399 ;; compute class and return the whole thing
400 (let ((class (or (and (> (length res) 0)
401 (digit-char-p (aref res 0)))
404 (if* (>= (length res) 3)
405 then ; compute the whole response value
406 (+ (* (or (digit-char-p (aref res 0)) 0) 100)
407 (* (or (digit-char-p (aref res 1)) 0) 10)
408 (or (digit-char-p (aref res 2)) 0))))))))
410 (defun smtp-command (stream &rest format-args)
411 ;; send a command to the smtp server
412 (let ((command (apply #'format nil format-args)))
414 then (format *smtp-debug* "to smtp command: ~s~%" command)
415 (force-output *smtp-debug*))
416 (write-string command stream)
417 (write-char #\return stream)
418 (write-char #\newline stream)
419 (force-output stream)))
421 (defun read-a-line (stream res)
422 ;; read from stream and put the result in the adjust able array res
423 ;; if line ends in cr-lf, only put a newline in res.
424 ;; If we get an eof before the line finishes, return nil,
425 ;; else return t if all is ok
428 (setq ch (read-char stream nil nil))
434 then (format *smtp-debug* "~c" ch)
435 (force-output *smtp-debug*)
438 (if* (eq last-ch #\return)
439 then (if* (eq ch #\linefeed)
440 then (vector-push-extend #\newline res)
442 else (vector-push-extend last-ch res))
443 elseif (eq ch #\linefeed)
444 then ; line ends with just lf, not cr-lf
445 (vector-push-extend #\newline res)
447 elseif (not (eq ch #\return))
448 then (vector-push-extend ch res))
453 (defun determine-mail-server (name)
454 ;; return the ipaddress to be used to connect to the
456 ;; name is any method for naming a machine:
457 ;; integer ip address
458 ;; string with dotted ip address
459 ;; string naming a machine
460 ;; we can only do the mx lookup for the third case, the rest
461 ;; we just return the ipaddress for what we were given
466 elseif (integerp (setq ipaddr
467 (socket:dotted-to-ipaddr name :errorp nil)))
469 else ; do mx lookup if acldns is being used
470 (if* (or (eq socket:*dns-mode* :acldns)
471 (member :acldns socket:*dns-mode* :test #'eq))
472 then (let ((res (socket:dns-query name :type :mx)))
473 (if* (and res (consp res))
474 then (cadr res) ; the ip address
475 else (socket:dns-query name :type :a)))
476 else ; just do a hostname lookup
477 (ignore-errors (socket:lookup-hostname name))))))