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.lisp,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
35 ;;#-allegro (defvar socket:*dns-mode* :clib)
39 (defpackage :net.post-office
42 #-allegro #:acl-socket)
46 #:test-email-address))
48 (in-package :net.post-office)
51 ;; the exported functions:
53 ;; (send-letter "mail-server" "from" "to" "message"
54 ;; &key cc bcc subject reply-to headers)
57 ;; sends a message to the mail server (which may be a relay server
58 ;; or the final destination). "from" is the address to be given
59 ;; as the sender. "to" can be a string or a list of strings naming
61 ;; "message" is the message to be sent
62 ;; cc and bcc can be either be a string or a list of strings
63 ;; naming recipients. All cc's and bcc's are sent the message
64 ;; but the bcc's aren't included in the header created.
65 ;; reply-to's value is a string and in cases a Reply-To header
67 ;; headers is a string or list of stings. These are raw header lines
68 ;; added to the header build to send out.
70 ;; This builds a header and inserts the optional cc, bcc,
71 ;; subject and reply-to lines.
73 ;; (send-smtp "mail-server" "from" "to" &rest messages)
74 ;; this is like send-letter except that it doesn't build a header.
75 ;; the messages should contain a header (and if not then sendmail
76 ;; notices this and builds one -- other MTAs may not be that smart).
77 ;; The messages ia list of strings to be concatenated together
78 ;; and sent as one message
81 ;; (test-email-address "user@machine.com")
82 ;; return t is this could be a valid email address on the machine
83 ;; named. Do this by contacting the mail server and using the VRFY
84 ;; command from smtp. Since some mail servers don't implement VRFY
85 ;; we return t if VRFY doesn't work.
86 ;; nil means that this address is bad (or we can't make contact with
87 ;; the mail server, which could of course be a transient problem).
94 (defmacro response-case ((smtp-stream &optional smtp-response response-code) &rest case-clauses)
95 ;; get a response from the smtp server and dispatch in a 'case' like
96 ;; fashion to a clause based on the first digit of the return
97 ;; code of the response.
98 ;; smtp-response, if given, will be bound to string that is
99 ;; the actual response
101 (let ((response-class (gensym)))
102 `(multiple-value-bind (,response-class
103 ,@(if* smtp-response then (list smtp-response))
104 ,@(if* response-code then (list response-code)))
105 (progn (force-output ,smtp-stream)
106 (wait-for-response ,smtp-stream))
107 ;;(declare (ignorable smtp-response))
108 (case ,response-class
111 (defvar *smtp-debug* nil)
115 (defun send-letter (server from to message
116 &key cc bcc subject reply-to headers)
118 ;; see documentation at the head of this file
120 (let ((header (make-string-output-stream))
121 (tos (if* (stringp to)
125 else (error "to should be a string or list, not ~s" to)))
133 else (error "cc should be a string or list, not ~s" cc)))
134 (bccs (if* (null bcc)
140 else (error "bcc should be a string or list, not ~s" bcc))))
141 (format header "From: ~a~c~cTo: "
145 (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed)
147 then (format header "Cc: ~{ ~a~^,~}~c~c" ccs #\return #\linefeed))
150 then (format header "Subject: ~a~c~c" subject #\return #\linefeed))
153 then (format header "Reply-To: ~a~c~c" reply-to #\return #\linefeed))
156 then (if* (stringp headers)
157 then (setq headers (list headers))
158 elseif (consp headers)
160 else (error "Unknown headers format: ~s." headers))
162 (format header "~a~c~c" h #\return #\linefeed)))
164 (format header "~c~c" #\return #\linefeed)
166 (send-smtp server from (append tos ccs bccs)
167 (get-output-stream-string header)
174 (defun send-smtp (server from to &rest messages)
175 ;; send the effective concatenation of the messages via
176 ;; smtp to the mail server
177 ;; Each message should be a string
179 ;; 'to' can be a single string or a list of strings.
180 ;; each string should be in the official rfc822 format "foo@bar.com"
183 (let ((sock (connect-to-mail-server server)))
188 (smtp-command sock "MAIL from:<~a>" from)
189 (response-case (sock msg)
193 (t (error "Mail from command failed: ~s" msg)))
195 (let ((tos (if* (stringp to)
199 else (error "to should be a string or list, not ~s"
202 (smtp-command sock "RCPT to:<~a>" to)
203 (response-case (sock msg)
207 (t (error "rcpt to command failed: ~s" msg)))))
209 (smtp-command sock "DATA")
210 (response-case (sock msg)
213 (t (error "Data command failed: ~s" msg)))
219 (dolist (message messages)
220 (dotimes (i (length message))
221 (let ((ch (aref message i)))
222 (if* (and at-bol (eq ch #\.))
223 then ; to prevent . from being interpreted as eol
224 (write-char #\. sock))
225 (if* (eq ch #\newline)
227 (if* (not (eq prev-ch #\return))
228 then (write-char #\return sock))
229 else (setq at-bol nil))
231 (setq prev-ch ch)))))
233 (write-char #\return sock) (write-char #\linefeed sock)
234 (write-char #\. sock)
235 (write-char #\return sock) (write-char #\linefeed sock)
237 (response-case (sock msg)
238 (2 nil ; (format t "Message sent to ~a~%" to)
241 (t (error "message not sent: ~s" msg)))
245 (smtp-command sock "QUIT")
246 (response-case (sock msg)
249 (t (error "quit failed: ~s" msg))))
252 (defun connect-to-mail-server (server)
253 ;; make that initial connection to the mail server
254 ;; returning a socket connected to it and
255 ;; signaling an error if it can't be made.
256 (let ((ipaddr (determine-mail-server server))
261 then (error "Can't determine ip addres for mail server ~s" server))
263 (setq sock (make-socket :remote-host ipaddr
264 :remote-port 25 ; smtp
268 (response-case (sock msg)
269 (2 ;; to the initial connect
271 (t (error "initial connect failed: ~s" msg)))
273 ;; now that we're connected we can compute our hostname
274 (let ((hostname (ipaddr-to-hostname
278 (format nil "[~a]" (ipaddr-to-dotted
279 (local-host sock)))))
280 (smtp-command sock "HELO ~a" hostname)
281 (response-case (sock msg)
284 (t (error "hello greeting failed: ~s" msg))))
291 then (close sock :abort t)
300 (defun test-email-address (address)
301 ;; test to see if we can determine if the address is valid
302 ;; return nil if the address is bogus
303 ;; return t if the address may or may not be bogus
304 (if* (or (not (stringp address))
305 (zerop (length address)))
306 then (error "mail address should be a non-empty string: ~s" address))
308 ; split on the @ sign
310 (let ((pos (position #\@ address)))
312 then (setq name address
313 hostname "localhost")
314 elseif (or (eql pos 0)
315 (eql pos (1- (length address))))
316 then ; @ at beginning or end, bogus since we don't do route addrs
317 (return-from test-email-address nil)
318 else (setq name (subseq address 0 pos)
319 hostname (subseq address (1+ pos)))))
321 (let ((sock (ignore-errors (connect-to-mail-server hostname))))
322 (if* (null sock) then (return-from test-email-address nil))
326 (smtp-command sock "VRFY ~a" name)
327 (response-case (sock msg code)
331 msg ; to remove unused warning
333 else t ; otherwise we don't know
336 (close sock :abort t)))))
352 (defun wait-for-response (stream)
353 ;; read the response of the smtp server.
354 ;; collect it all in a string.
355 ;; Return two values:
358 ;; The string should begin with a decimal digit, and that is converted
359 ;; into a number which is returned as the response class.
360 ;; If the string doesn't begin with a decimal digit then the
361 ;; response class is -1.
363 (flet ((match-chars (string pos1 pos2 count)
366 (if* (not (eq (aref string (+ pos1 i))
367 (aref string (+ pos2 i))))
368 then (return nil)))))
370 (let ((res (make-array 20 :element-type 'character
373 (if* (null (read-a-line stream res))
374 then ; eof encountered before end of line
375 (return-from wait-for-response (values -1 res)))
377 ;; a multi-line response begins with line containing
378 ;; a hyphen in the 4th column:
381 ;; and ends with a line containing the same reply code but no
386 (if* (and (>= (length res) 4) (eq #\- (aref res 3)))
387 then ;; multi line response
388 (let ((old-length (length res))
391 (if* (null (read-a-line stream res))
392 then ; eof encountered before end of line
393 (return-from wait-for-response (values -1 res)))
394 (setq new-length (length res))
395 ;; see if this is the last line
396 (if* (and (>= (- new-length old-length) 4)
397 (eq (aref res (+ old-length 3)) #\space)
398 (match-chars res 0 old-length 3))
401 (setq old-length new-length))))
403 ;; complete response is in res
404 ;; compute class and return the whole thing
405 (let ((class (or (and (> (length res) 0)
406 (digit-char-p (aref res 0)))
409 (if* (>= (length res) 3)
410 then ; compute the whole response value
411 (+ (* (or (digit-char-p (aref res 0)) 0) 100)
412 (* (or (digit-char-p (aref res 1)) 0) 10)
413 (or (digit-char-p (aref res 2)) 0))))))))
415 (defun smtp-command (stream &rest format-args)
416 ;; send a command to the smtp server
417 (let ((command (apply #'format nil format-args)))
419 then (format *smtp-debug* "to smtp command: ~s~%" command)
420 (force-output *smtp-debug*))
421 (write-string command stream)
422 (write-char #\return stream)
423 (write-char #\newline stream)
424 (force-output stream)))
426 (defun read-a-line (stream res)
427 ;; read from stream and put the result in the adjust able array res
428 ;; if line ends in cr-lf, only put a newline in res.
429 ;; If we get an eof before the line finishes, return nil,
430 ;; else return t if all is ok
433 (setq ch (read-char stream nil nil))
439 then (format *smtp-debug* "~c" ch)
440 (force-output *smtp-debug*)
443 (if* (eq last-ch #\return)
444 then (if* (eq ch #\linefeed)
445 then (vector-push-extend #\newline res)
447 else (vector-push-extend last-ch res))
448 elseif (eq ch #\linefeed)
449 then ; line ends with just lf, not cr-lf
450 (vector-push-extend #\newline res)
452 elseif (not (eq ch #\return))
453 then (vector-push-extend ch res))
458 (defun determine-mail-server (name)
459 ;; return the ipaddress to be used to connect to the
461 ;; name is any method for naming a machine:
462 ;; integer ip address
463 ;; string with dotted ip address
464 ;; string naming a machine
465 ;; we can only do the mx lookup for the third case, the rest
466 ;; we just return the ipaddress for what we were given
471 elseif (integerp (setq ipaddr
472 (dotted-to-ipaddr name :errorp nil)))
474 else ; do mx lookup if acldns is being used
476 (if* (or (eq *dns-mode* :acldns)
477 (member :acldns *dns-mode* :test #'eq))
478 then (let ((res (dns-query name :type :mx)))
479 (if* (and res (consp res))
480 then (cadr res) ; the ip address
481 else (dns-query name :type :a)))
482 else ; just do a hostname lookup
484 (ignore-errors (lookup-hostname name)))))