;; -*- mode: common-lisp; package: net.post-office -*-
;; send mail to an smtp server. See rfc821 for the spec.
;;
;; See the file LICENSE for the full license governing this code.
#+(or (version= 8 2)
(version= 9 0))
(sys:defpatch "smtp" 2
"v1: Handle SMTP servers which violate SMTP SASL AUTH protocol;
v2: add new type of server argument to send-letter."
:type :system
:post-loadable t)
#+(version= 8 1)
(sys:defpatch "smtp" 1
"v1: add smtp support for ssl connections and STARTTLS negotiation."
:type :system
:post-loadable t)
(eval-when (compile eval load)
(require :osi))
(defpackage :net.post-office
(:use #:lisp #:excl #:excl.osi)
(:export
#:send-letter
#:send-smtp
#:send-smtp-auth
#:test-email-address))
(in-package :net.post-office)
(eval-when (compile load eval)
(require :streamp)
(require :sasl)
(require :mime))
;; the exported functions:
;; (send-letter "mail-server" "from" "to" "message"
;; &key cc bcc subject reply-to headers)
;;
;;
;; sends a message to the mail server (which may be a relay server
;; or the final destination). "from" is the address to be given
;; as the sender. "to" can be a string or a list of strings naming
;; recipients.
;; "message" is the message to be sent. It can be a string or a stream.
;; cc and bcc can be either be a string or a list of strings
;; naming recipients. All cc's and bcc's are sent the message
;; but the bcc's aren't included in the header created.
;; reply-to's value is a string and in cases a Reply-To header
;; to be created.
;; headers is a string or list of stings. These are raw header lines
;; added to the header build to send out.
;;
;; This builds a header and inserts the optional cc, bcc,
;; subject and reply-to lines.
;;
;; (send-smtp "mail-server" "from" "to" &rest messages)
;; this is like send-letter except that it doesn't build a header.
;; the messages should contain a header (and if not then sendmail
;; notices this and builds one -- other MTAs may not be that smart).
;; The messages ia list of strings or streams to be concatenated together
;; and sent as one message
;;
;;
;; (test-email-address "user@machine.com")
;; return t is this could be a valid email address on the machine
;; named. Do this by contacting the mail server and using the VRFY
;; command from smtp. Since some mail servers don't implement VRFY
;; we return t if VRFY doesn't work.
;; nil means that this address is bad (or we can't make contact with
;; the mail server, which could of course be a transient problem).
;;
(defmacro response-case ((smtp-stream &optional smtp-response response-code) &rest case-clauses)
;; get a response from the smtp server and dispatch in a 'case' like
;; fashion to a clause based on the first digit of the return
;; code of the response.
;; smtp-response, if given, will be bound to string that is
;; the actual response
;;
(let ((response-class (gensym)))
`(multiple-value-bind (,response-class
,@(if* smtp-response then (list smtp-response))
,@(if* response-code then (list response-code)))
(progn (force-output ,smtp-stream)
(wait-for-response ,smtp-stream))
;;(declare (ignorable smtp-response))
(case ,response-class
,@case-clauses))))
(defmacro smtp-send-recv ((smtp-stream cmd smtp-response &optional response-code) &rest case-clauses)
(let ((stream (gensym))
(sent (gensym)))
`(let ((,stream ,smtp-stream)
(,sent ,cmd))
(if* *smtp-debug*
then (format *smtp-debug* "to smtp command: ~s~%" ,sent)
(force-output *smtp-debug*))
(write-string ,sent ,stream)
(write-char #\return ,stream)
(write-char #\newline ,stream)
(force-output ,stream)
(macrolet ((smtp-transaction-error ()
(list
'error
"SMTP transaction failed. We said: ~s, and the server replied: ~s"
(quote ,sent)
(quote ,smtp-response))))
(response-case (,stream ,smtp-response ,response-code)
,@case-clauses)))))
(defvar *smtp-debug* nil)
(defun send-letter (server from to message
&key cc bcc subject reply-to headers
login password attachments)
;;
;; see documentation at the head of this file
;;
(if* (mime-part-constructed-p message)
then (if* (and (not (multipart-mixed-p message)) attachments)
then (error "~
attachments are not allowed for non-multipart/mixed messages."))
else (let ((part
(if* (streamp message)
then
(make-mime-part :file message)
elseif (stringp message)
then (make-mime-part :text message)
else (error "~
message must be a string, stream, or mime-part-constructed, not ~s" message))))
(setf message
(if* attachments
then (make-mime-part :subparts (list part))
else part))))
(let ((hdrs nil)
(user-headers "")
(tos (if* (stringp to)
then (list to)
elseif (consp to)
then to
else (error "to should be a string or list, not ~s" to)))
(ccs
(if* (null cc)
then nil
elseif (stringp cc)
then (list cc)
elseif (consp cc)
then cc
else (error "cc should be a string or list, not ~s" cc)))
(bccs (if* (null bcc)
then nil
elseif (stringp bcc)
then (list bcc)
elseif (consp bcc)
then bcc
else (error "bcc should be a string or list, not ~s" bcc))))
(setf hdrs
(with-output-to-string (hdrs)
(macrolet ((already-have (name)
`(mime-get-header ,name message)))
;; Give priority to headers already provided in a mime-part.
(if* (not (already-have "From"))
then (format hdrs "From: ~a~%" from))
(if* (not (already-have "To"))
then (format hdrs "To: ~a~%" (list-to-delimited-string tos ", ")))
(if* (and ccs (not (already-have "Cc")))
then (format hdrs "Cc: ~a~%" (list-to-delimited-string ccs ", ")))
(if* (and subject (not (already-have "Subject")))
then (format hdrs "Subject: ~a~%" subject))
(if* (and reply-to (not (already-have "Reply-To")))
then (format hdrs "Reply-To: ~a~%" reply-to)))))
(if* headers
then (if* (stringp headers)
then (setq headers (list headers))
elseif (consp headers)
thenret
else (error "Unknown headers format: ~s." headers))
(setf user-headers
(with-output-to-string (header)
(dolist (h headers)
(format header "~a~%" h)))))
;; Temporarily modifies 'message', which may be user-provided.
(let ((parts-save (mime-part-parts message)))
(if* attachments
then (if (not (consp attachments))
(setf attachments (list attachments)))
(let (res)
(dolist (attachment attachments)
(if* (mime-part-constructed-p attachment)
thenret
elseif (or (streamp attachment) (stringp attachment)
(pathnamep attachment))
then (setf attachment (make-mime-part :file attachment))
else (error "~
Attachments must be filenames, streams, or mime-part-constructed, not ~s"
attachment))
(push attachment res))
(setf (mime-part-parts message) (append parts-save res))))
(with-mime-part-constructed-stream (s message)
(if* (and (consp server) (eq :program (car server)))
then (send-external-program (cdr server) hdrs user-headers s)
else (send-smtp-auth server from (append tos ccs bccs)
login password
hdrs
user-headers
s)))
(setf (mime-part-parts message) parts-save)
t)))
(defun send-external-program (program &rest messages
&aux (external-format :default))
(multiple-value-bind (stdout stderr exit-status)
(command-output
(if* (stringp program)
then program
elseif (consp program)
then #+mswindows program
#-mswindows (apply #'vector (car program) program)
else (error "Bad program argument: ~s." program))
:input (lambda (stream)
(create-message stream messages external-format)))
(when (/= 0 exit-status)
(error "external program failed to send email (~s, ~s)."
stdout stderr))))
(defun create-message (output-stream messages external-format)
(let ((at-bol t)
(prev-ch nil)
ch input-stream)
(dolist (message messages)
(when message
(setq input-stream
(if* (streamp message)
then message
else (make-buffer-input-stream
(string-to-octets
message
:null-terminate nil
:external-format external-format))))
(while (setf ch (read-byte input-stream nil))
(if* (and at-bol (eq ch #.(char-code #\.)))
then ;; to prevent . from being interpreted as eol
(write-char #\. output-stream))
(if* (eq ch #.(char-code #\newline))
then (setq at-bol t)
(if* (not (eq prev-ch #.(char-code #\return)))
then (write-char #\return output-stream))
else (setq at-bol nil))
(write-byte ch output-stream)
(setq prev-ch ch)))))
(write-char #\return output-stream)
(write-char #\linefeed output-stream)
(write-char #\. output-stream)
(write-char #\return output-stream)
(write-char #\linefeed output-stream))
(defun send-smtp (server from to &rest messages)
(send-smtp-1 server from to nil nil messages))
(defun send-smtp-auth (server from to login password &rest messages)
(send-smtp-1 server from to login password messages))
(defun send-smtp-1 (server from to login password messages
&key (external-format
;; Never used, this might as well be an &aux
;; variable
:default))
;; send the effective concatenation of the messages via
;; smtp to the mail server
;; Each message should be a string or a stream.
;;
;; 'to' can be a single string or a list of strings.
;; each string should be in the official rfc822 format "foo@bar.com"
;;
(let ((sock (connect-to-mail-server server login password)))
(unwind-protect
(progn
(smtp-send-recv (sock (format nil "MAIL from:<~a>" from) msg)
(2 ;; cool
nil
)
(t (smtp-transaction-error)))
(let ((tos (if* (stringp to)
then (list to)
elseif (consp to)
then to
else (error "to should be a string or list, not ~s"
to))))
(dolist (to tos)
(smtp-send-recv (sock (format nil "RCPT to:<~a>" to) msg)
(2 ;; cool
nil
)
(t (smtp-transaction-error)))))
(smtp-send-recv (sock "DATA" msg)
(3 ;; cool
nil)
(t (smtp-transaction-error)))
(create-message sock messages external-format)
(response-case (sock msg)
(2 nil ; (format t "Message sent to ~a~%" to)
)
(t (error "message not sent: ~s" msg)))
(smtp-send-recv (sock "QUIT" msg)
(2 ;; cool
nil)
(t (smtp-transaction-error))))
;; Cleanup
(close sock))))
(defun connect-to-mail-server (server login password)
;; make that initial connection to the mail server
;; returning a socket connected to it and
;; signaling an error if it can't be made.
(let ((use-port 25) ;; standard SMTP port
ssl-args
ssl
starttls)
(if* (consp server)
then (if* (consp (cdr server))
then ;; long form
(setq ssl-args (cdr server))
(setf server (car server))
(setq ssl (getf ssl-args :ssl))
(remf ssl-args :ssl)
(setq use-port (or (getf ssl-args :port)
(if ssl 465 use-port)))
(remf ssl-args :port)
(setq starttls (getf ssl-args :starttls))
(remf ssl-args :starttls)
else ;; short form
(setf use-port (cdr server))
(setf server (car server)))
elseif (stringp server)
then (multiple-value-bind (match whole m1 m2)
(match-re "^([^:]+):([0-9]+)$" server)
(declare (ignore whole))
(if* match
then (setf server m1)
(setf use-port (parse-integer m2)))))
(let ((ipaddr (determine-mail-server server))
(sock)
(ok))
(if* (null ipaddr)
then (error "Can't determine ip address for mail server ~s" server))
(setq sock (socket:make-socket :remote-host ipaddr
:remote-port use-port
))
(when ssl
(setq sock (apply #'acl-socket:make-ssl-client-stream sock ssl-args)))
(unwind-protect
(tagbody
(response-case (sock msg)
(2 ;; to the initial connect
nil)
(t (error "initial connect failed: ~s" msg)))
ehlo
;; now that we're connected we can compute our hostname
(let ((hostname (socket:ipaddr-to-hostname
(socket:local-host sock))))
(if* (null hostname)
then (setq hostname
(format nil "[~a]" (socket:ipaddr-to-dotted
(socket:local-host sock)))))
(let ((mechs (smtp-ehlo sock hostname))
auth-mechs)
(if* (and mechs starttls (member "STARTTLS" mechs :test #'string=))
then (smtp-send-recv (sock (format nil "STARTTLS") msg)
(2 ;; ok
(setq sock (acl-socket:make-ssl-client-stream sock :method :tlsv1)))
(t (smtp-transaction-error)))
(go ehlo)
elseif (and mechs login password
(setq auth-mechs (car (member "LOGIN" mechs
:test #'(lambda (x y) (search x y))))))
then (setf sock
(smtp-authenticate sock server auth-mechs login password)))))
;; all is good
(setq ok t))
;; cleanup:
(if* (null ok)
then (close sock :abort t)
(setq sock nil)))
;; return:
sock
)))
;; Returns string with mechanisms, or nil if none.
;; This may need to be expanded in the future as we support
;; more of the features that EHLO responds with.
(defun smtp-ehlo (sock our-name)
(smtp-send-recv (sock (format nil "EHLO ~A" our-name) msg)
(2 ;; ok
;; Collect the auth mechanisms.
(let (mechs)
(multiple-value-bind (found whole mech)
(match-re "250[- ]AUTH (.*)" msg)
(declare (ignore whole))
(if found (push mech mechs)))
(multiple-value-bind (found whole mech)
(match-re "250[- ](STARTTLS)" msg)
(declare (ignore whole))
(if found (push mech mechs)))
mechs))
(t
(smtp-send-recv (sock (format nil "HELO ~A" our-name) msg)
(2 ;; ok
nil)
(t (smtp-transaction-error))))))
(defun smtp-authenticate (sock server mechs login password)
(let ((ctx (net.sasl:sasl-client-new "smtp" server
:user login
:pass password))
(first-server-response t))
(multiple-value-bind (res selected-mech response)
(net.sasl:sasl-client-start ctx mechs)
(if (not (eq res :continue))
(error "sasl-client-start unexpectedly returned: ~s" res))
(smtp-command sock "AUTH ~a" selected-mech)
(loop
(response-case (sock msg)
(3 ;; need more interaction
;; [rfe12276] Some SMTP servers (notably The Amazon SES
;; SMTP endpoint (email-smtp.us-east-1.amazonaws.com))
;; violate the protocol rules on the first server response.
;; Apparently other SMTP clients are tolerant of this, so
;; we try to be as well.
(multiple-value-bind (decoded-server-response err)
(ignore-errors (base64-string-to-usb8-array (subseq msg 4)))
(when (null decoded-server-response)
(if* first-server-response
then ;; Ignore initial server response if it's
;; bogus.
;;;(warn "Bogus server initial response: ~s~%" (subseq msg 4))
(setf first-server-response nil)
else ;; We tolerate a bogus initial response, but no others
(error "Failed to decode server response of ~s: ~a"
(subseq msg 4)
err)))
(multiple-value-setq (res response)
(net.sasl:sasl-step ctx decoded-server-response))
(smtp-command sock "~a"
(usb8-array-to-base64-string response nil))))
(2 ;; server is satisfied.
;; Make sure the auth process really completed
(if (not (net.sasl:sasl-conn-auth-complete-p ctx))
(error "SMTP server indicated authentication complete before mechanisms was satisfied"))
;; It's all good.
(return)) ;; break from loop
(t
(error "SMTP authentication failed: ~a" msg)))))
;; Reach here if authentication completed.
;; If a security layer was negotiated, return an encapsulated sock,
;; otherwise just return the original sock.
(if (net.sasl:sasl-conn-security-layer-p ctx)
(net.sasl:sasl-make-stream ctx sock :close-base t)
sock)))
(defun test-email-address (address)
;; test to see if we can determine if the address is valid
;; return nil if the address is bogus
;; return t if the address may or may not be bogus
(if* (or (not (stringp address))
(zerop (length address)))
then (error "mail address should be a non-empty string: ~s" address))
; split on the @ sign
(let (name hostname)
(let ((pos (position #\@ address)))
(if* (null pos)
then (setq name address
hostname "localhost")
elseif (or (eql pos 0)
(eql pos (1- (length address))))
then ; @ at beginning or end, bogus since we don't do route addrs
(return-from test-email-address nil)
else (setq name (subseq address 0 pos)
hostname (subseq address (1+ pos)))))
(let ((sock (ignore-errors (connect-to-mail-server hostname nil nil))))
(if* (null sock) then (return-from test-email-address nil))
(unwind-protect
(progn
(smtp-send-recv (sock (format nil "VRFY ~a" name) msg code)
(5
(if* (eq code 550)
then ; no such user
msg ; to remove unused warning
nil
else ;; otherwise we don't know
(return-from test-email-address t)))
(t (return-from test-email-address t)))
(smtp-send-recv (sock (format nil "VRFY ~a" address) msg code)
(5
(if* (eq code 550)
then ; no such user
msg ; to remove unused warning
nil
else t))
(t t)))
(close sock :abort t)))))
(defun wait-for-response (stream)
;; read the response of the smtp server.
;; collect it all in a string.
;; Return two values:
;; response class
;; whole string
;; The string should begin with a decimal digit, and that is converted
;; into a number which is returned as the response class.
;; If the string doesn't begin with a decimal digit then the
;; response class is -1.
;;
(flet ((match-chars (string pos1 pos2 count)
;; like strncmp
(dotimes (i count t)
(if* (not (eq (aref string (+ pos1 i))
(aref string (+ pos2 i))))
then (return nil)))))
(let ((res (make-array 20 :element-type 'character
:adjustable t
:fill-pointer 0)))
(if* (null (read-a-line stream res))
then ; eof encountered before end of line
(return-from wait-for-response (values -1 res)))
;; a multi-line response begins with line containing
;; a hyphen in the 4th column:
;; xyz- some text
;;
;; and ends with a line containing the same reply code but no
;; hyphen.
;; xyz some text
;;
(if* (and (>= (length res) 4) (eq #\- (aref res 3)))
then ;; multi line response
(let ((old-length (length res))
(new-length nil))
(loop
(if* (null (read-a-line stream res))
then ; eof encountered before end of line
(return-from wait-for-response (values -1 res)))
(setq new-length (length res))
;; see if this is the last line
(if* (and (>= (- new-length old-length) 4)
(eq (aref res (+ old-length 3)) #\space)
(match-chars res 0 old-length 3))
then (return))
(setq old-length new-length))))
;; complete response is in res
;; compute class and return the whole thing
(let ((class (or (and (> (length res) 0)
(digit-char-p (aref res 0)))
-1)))
(values class res
(if* (>= (length res) 3)
then ; compute the whole response value
(+ (* (or (digit-char-p (aref res 0)) 0) 100)
(* (or (digit-char-p (aref res 1)) 0) 10)
(or (digit-char-p (aref res 2)) 0))))))))
(defun smtp-command (stream &rest format-args)
;; send a command to the smtp server
(let ((command (apply #'format nil format-args)))
(if* *smtp-debug*
then (format *smtp-debug* "to smtp command: ~s~%" command)
(force-output *smtp-debug*))
(write-string command stream)
(write-char #\return stream)
(write-char #\newline stream)
(force-output stream)))
(defun read-a-line (stream res)
;; read from stream and put the result in the adjust able array res
;; if line ends in cr-lf, only put a newline in res.
;; If we get an eof before the line finishes, return nil,
;; else return t if all is ok
(let (ch last-ch)
(loop
(setq ch (read-char stream nil nil))
(if* (null ch)
then ; premature eof
(return nil))
(if* *smtp-debug*
then (format *smtp-debug* "~c" ch)
(force-output *smtp-debug*)
)
(if* (eq last-ch #\return)
then (if* (eq ch #\linefeed)
then (vector-push-extend #\newline res)
(return t)
else (vector-push-extend last-ch res))
elseif (eq ch #\linefeed)
then ; line ends with just lf, not cr-lf
(vector-push-extend #\newline res)
(return t)
elseif (not (eq ch #\return))
then (vector-push-extend ch res))
(setq last-ch ch))))
(eval-when (compile eval)
(defmacro ipaddrp (obj)
#+(version>= 8 0) `(socket:ipaddrp ,obj)
#-(version>= 8 0) `(and (integerp ,obj) (<= 0 ,obj #.(1- (expt 2 32)))))
)
(defun determine-mail-server (name)
;; return the ipaddress to be used to connect to the
;; the mail server.
;; name is any method for naming a machine:
;; ip address (binary)
;; string with dotted ip address
;; string naming a domain
;; we can only do the mx lookup for the third case, the rest
;; we just return the ipaddress for what we were given
;;
(let (ipaddr)
(if* (ipaddrp name)
then name
elseif (ipaddrp (setq ipaddr (socket:dotted-to-ipaddr name :errorp nil)))
then ipaddr
else ; do mx lookup if acldns is being used
(if* (or (eq socket:*dns-mode* :acldns)
(and (consp socket:*dns-mode*)
(member :acldns socket:*dns-mode* :test #'eq)))
then (let ((res (socket:dns-query name :type :mx)))
(if* (and (consp res) (cadr res))
then (cadr res) ; the ip address
else (dolist (suffix socket::*domain-search-list*
(socket:dns-lookup-hostname name))
(declare (special socket:*domain-search-list*))
(let ((name
(concatenate 'string name "." suffix)))
(setq res (socket:dns-query name :type :mx))
(if* (and res (cadr res))
then (return (cadr res)))))))
else ; just do a hostname lookup
(ignore-errors (socket:lookup-hostname name))))))
(provide :smtp)