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.2 2002/10/09 23:28:41 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 (in-package :net.post-office)
42 ;; the exported functions:
44 ;; (send-letter "mail-server" "from" "to" "message"
45 ;; &key cc bcc subject reply-to headers)
48 ;; sends a message to the mail server (which may be a relay server
49 ;; or the final destination). "from" is the address to be given
50 ;; as the sender. "to" can be a string or a list of strings naming
52 ;; "message" is the message to be sent
53 ;; cc and bcc can be either be a string or a list of strings
54 ;; naming recipients. All cc's and bcc's are sent the message
55 ;; but the bcc's aren't included in the header created.
56 ;; reply-to's value is a string and in cases a Reply-To header
58 ;; headers is a string or list of stings. These are raw header lines
59 ;; added to the header build to send out.
61 ;; This builds a header and inserts the optional cc, bcc,
62 ;; subject and reply-to lines.
64 ;; (send-smtp "mail-server" "from" "to" &rest messages)
65 ;; this is like send-letter except that it doesn't build a header.
66 ;; the messages should contain a header (and if not then sendmail
67 ;; notices this and builds one -- other MTAs may not be that smart).
68 ;; The messages ia list of strings to be concatenated together
69 ;; and sent as one message
72 ;; (test-email-address "user@machine.com")
73 ;; return t is this could be a valid email address on the machine
74 ;; named. Do this by contacting the mail server and using the VRFY
75 ;; command from smtp. Since some mail servers don't implement VRFY
76 ;; we return t if VRFY doesn't work.
77 ;; nil means that this address is bad (or we can't make contact with
78 ;; the mail server, which could of course be a transient problem).
85 (defmacro response-case ((smtp-stream &optional smtp-response response-code) &rest case-clauses)
86 ;; get a response from the smtp server and dispatch in a 'case' like
87 ;; fashion to a clause based on the first digit of the return
88 ;; code of the response.
89 ;; smtp-response, if given, will be bound to string that is
90 ;; the actual response
92 (let ((response-class (gensym)))
93 `(multiple-value-bind (,response-class
94 ,@(if* smtp-response then (list smtp-response))
95 ,@(if* response-code then (list response-code)))
96 (progn (force-output ,smtp-stream)
97 (wait-for-response ,smtp-stream))
98 ;;(declare (ignorable smtp-response))
102 (defvar *smtp-debug* nil)
106 (defun send-letter (server from to message
107 &key cc bcc subject reply-to headers)
109 ;; see documentation at the head of this file
111 (let ((header (make-string-output-stream))
112 (tos (if* (stringp to)
116 else (error "to should be a string or list, not ~s" to)))
124 else (error "cc should be a string or list, not ~s" cc)))
125 (bccs (if* (null bcc)
131 else (error "bcc should be a string or list, not ~s" bcc))))
132 (format header "From: ~a~c~cTo: "
136 (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed)
138 then (format header "Cc: ~{ ~a~^,~}~c~c" ccs #\return #\linefeed))
141 then (format header "Subject: ~a~c~c" subject #\return #\linefeed))
144 then (format header "Reply-To: ~a~c~c" reply-to #\return #\linefeed))
147 then (if* (stringp headers)
148 then (setq headers (list headers))
149 elseif (consp headers)
151 else (error "Unknown headers format: ~s." headers))
153 (format header "~a~c~c" h #\return #\linefeed)))
155 (format header "~c~c" #\return #\linefeed)
157 (send-smtp server from (append tos ccs bccs)
158 (get-output-stream-string header)
165 (defun send-smtp (server from to &rest messages)
166 ;; send the effective concatenation of the messages via
167 ;; smtp to the mail server
168 ;; Each message should be a string
170 ;; 'to' can be a single string or a list of strings.
171 ;; each string should be in the official rfc822 format "foo@bar.com"
174 (let ((sock (connect-to-mail-server server)))
179 (smtp-command sock "MAIL from:<~a>" from)
180 (response-case (sock msg)
184 (t (error "Mail from command failed: ~s" msg)))
186 (let ((tos (if* (stringp to)
190 else (error "to should be a string or list, not ~s"
193 (smtp-command sock "RCPT to:<~a>" to)
194 (response-case (sock msg)
198 (t (error "rcpt to command failed: ~s" msg)))))
200 (smtp-command sock "DATA")
201 (response-case (sock msg)
204 (t (error "Data command failed: ~s" msg)))
210 (dolist (message messages)
211 (dotimes (i (length message))
212 (let ((ch (aref message i)))
213 (if* (and at-bol (eq ch #\.))
214 then ; to prevent . from being interpreted as eol
215 (write-char #\. sock))
216 (if* (eq ch #\newline)
218 (if* (not (eq prev-ch #\return))
219 then (write-char #\return sock))
220 else (setq at-bol nil))
222 (setq prev-ch ch)))))
224 (write-char #\return sock) (write-char #\linefeed sock)
225 (write-char #\. sock)
226 (write-char #\return sock) (write-char #\linefeed sock)
228 (response-case (sock msg)
229 (2 nil ; (format t "Message sent to ~a~%" to)
232 (t (error "message not sent: ~s" msg)))
236 (smtp-command sock "QUIT")
237 (response-case (sock msg)
240 (t (error "quit failed: ~s" msg))))
243 (defun connect-to-mail-server (server)
244 ;; make that initial connection to the mail server
245 ;; returning a socket connected to it and
246 ;; signaling an error if it can't be made.
247 (let ((ipaddr (determine-mail-server server))
252 then (error "Can't determine ip addres for mail server ~s" server))
254 (setq sock (make-socket :remote-host ipaddr
255 :remote-port 25 ; smtp
259 (response-case (sock msg)
260 (2 ;; to the initial connect
262 (t (error "initial connect failed: ~s" msg)))
264 ;; now that we're connected we can compute our hostname
265 (let ((hostname (ipaddr-to-hostname
269 (format nil "[~a]" (ipaddr-to-dotted
270 (local-host sock)))))
271 (smtp-command sock "HELO ~a" hostname)
272 (response-case (sock msg)
275 (t (error "hello greeting failed: ~s" msg))))
282 then (close sock :abort t)
291 (defun test-email-address (address)
292 ;; test to see if we can determine if the address is valid
293 ;; return nil if the address is bogus
294 ;; return t if the address may or may not be bogus
295 (if* (or (not (stringp address))
296 (zerop (length address)))
297 then (error "mail address should be a non-empty string: ~s" address))
299 ; split on the @ sign
301 (let ((pos (position #\@ address)))
303 then (setq name address
304 hostname "localhost")
305 elseif (or (eql pos 0)
306 (eql pos (1- (length address))))
307 then ; @ at beginning or end, bogus since we don't do route addrs
308 (return-from test-email-address nil)
309 else (setq name (subseq address 0 pos)
310 hostname (subseq address (1+ pos)))))
312 (let ((sock (ignore-errors (connect-to-mail-server hostname))))
313 (if* (null sock) then (return-from test-email-address nil))
317 (smtp-command sock "VRFY ~a" name)
318 (response-case (sock msg code)
322 msg ; to remove unused warning
324 else t ; otherwise we don't know
327 (close sock :abort t)))))
343 (defun wait-for-response (stream)
344 ;; read the response of the smtp server.
345 ;; collect it all in a string.
346 ;; Return two values:
349 ;; The string should begin with a decimal digit, and that is converted
350 ;; into a number which is returned as the response class.
351 ;; If the string doesn't begin with a decimal digit then the
352 ;; response class is -1.
354 (flet ((match-chars (string pos1 pos2 count)
357 (if* (not (eq (aref string (+ pos1 i))
358 (aref string (+ pos2 i))))
359 then (return nil)))))
361 (let ((res (make-array 20 :element-type 'character
364 (if* (null (read-a-line stream res))
365 then ; eof encountered before end of line
366 (return-from wait-for-response (values -1 res)))
368 ;; a multi-line response begins with line containing
369 ;; a hyphen in the 4th column:
372 ;; and ends with a line containing the same reply code but no
377 (if* (and (>= (length res) 4) (eq #\- (aref res 3)))
378 then ;; multi line response
379 (let ((old-length (length res))
382 (if* (null (read-a-line stream res))
383 then ; eof encountered before end of line
384 (return-from wait-for-response (values -1 res)))
385 (setq new-length (length res))
386 ;; see if this is the last line
387 (if* (and (>= (- new-length old-length) 4)
388 (eq (aref res (+ old-length 3)) #\space)
389 (match-chars res 0 old-length 3))
392 (setq old-length new-length))))
394 ;; complete response is in res
395 ;; compute class and return the whole thing
396 (let ((class (or (and (> (length res) 0)
397 (digit-char-p (aref res 0)))
400 (if* (>= (length res) 3)
401 then ; compute the whole response value
402 (+ (* (or (digit-char-p (aref res 0)) 0) 100)
403 (* (or (digit-char-p (aref res 1)) 0) 10)
404 (or (digit-char-p (aref res 2)) 0))))))))
406 (defun smtp-command (stream &rest format-args)
407 ;; send a command to the smtp server
408 (let ((command (apply #'format nil format-args)))
410 then (format *smtp-debug* "to smtp command: ~s~%" command)
411 (force-output *smtp-debug*))
412 (write-string command stream)
413 (write-char #\return stream)
414 (write-char #\newline stream)
415 (force-output stream)))
417 (defun read-a-line (stream res)
418 ;; read from stream and put the result in the adjust able array res
419 ;; if line ends in cr-lf, only put a newline in res.
420 ;; If we get an eof before the line finishes, return nil,
421 ;; else return t if all is ok
424 (setq ch (read-char stream nil nil))
430 then (format *smtp-debug* "~c" ch)
431 (force-output *smtp-debug*)
434 (if* (eq last-ch #\return)
435 then (if* (eq ch #\linefeed)
436 then (vector-push-extend #\newline res)
438 else (vector-push-extend last-ch res))
439 elseif (eq ch #\linefeed)
440 then ; line ends with just lf, not cr-lf
441 (vector-push-extend #\newline res)
443 elseif (not (eq ch #\return))
444 then (vector-push-extend ch res))
449 (defun determine-mail-server (name)
450 ;; return the ipaddress to be used to connect to the
452 ;; name is any method for naming a machine:
453 ;; integer ip address
454 ;; string with dotted ip address
455 ;; string naming a machine
456 ;; we can only do the mx lookup for the third case, the rest
457 ;; we just return the ipaddress for what we were given
462 elseif (integerp (setq ipaddr
463 (dotted-to-ipaddr name :errorp nil)))
465 else ; do mx lookup if acldns is being used
467 (if* (or (eq *dns-mode* :acldns)
468 (member :acldns *dns-mode* :test #'eq))
469 then (let ((res (dns-query name :type :mx)))
470 (if* (and res (consp res))
471 then (cadr res) ; the ip address
472 else (dns-query name :type :a)))
473 else ; just do a hostname lookup
475 (ignore-errors (lookup-hostname name)))))