X-Git-Url: http://git.kpe.io/?p=postoffice.git;a=blobdiff_plain;f=smtp.lisp;fp=smtp.lisp;h=3536d9d88a8767751c0cbba60724c964a46dbbd1;hp=d639abbcb02f287296ed0fa0476702e4c0db277b;hb=3a66fac314ca96aa41f6a91a607c8604c55c66a4;hpb=9a613ba731125584906aeb4886869428e2c3ba32 diff --git a/smtp.lisp b/smtp.lisp index d639abb..3536d9d 100644 --- a/smtp.lisp +++ b/smtp.lisp @@ -2,11 +2,11 @@ ;; ;; smtp.cl ;; -;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA ;; ;; This code is free software; you can redistribute it and/or ;; modify it under the terms of the version 2.1 of -;; the GNU Lesser General Public License as published by +;; the GNU Lesser General Public License as published by ;; the Free Software Foundation, as clarified by the AllegroServe ;; prequel found in license-allegroserve.txt. ;; @@ -15,11 +15,11 @@ ;; merchantability or fitness for a particular purpose. See the GNU ;; Lesser General Public License for more details. ;; -;; Version 2.1 of the GNU Lesser General Public License is in the file +;; Version 2.1 of the GNU Lesser General Public License is in the file ;; license-lgpl.txt that was distributed with this file. ;; If it is not present, you can access it from ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer -;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, ;; Suite 330, Boston, MA 02111-1307 USA ;; ;; @@ -41,24 +41,24 @@ ;; the exported functions: -;; (send-letter "mail-server" "from" "to" "message" -;; &key cc bcc subject reply-to headers) -;; -;; +;; (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. +;; recipients. ;; "message" is the message to be sent ;; 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. +;; 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. +;; to be created. ;; headers is a string or list of stings. These are raw header lines -;; added to the header build to send out. +;; added to the header build to send out. ;; -;; This builds a header and inserts the optional cc, bcc, +;; This builds a header and inserts the optional cc, bcc, ;; subject and reply-to lines. ;; ;; (send-smtp "mail-server" "from" "to" &rest messages) @@ -88,79 +88,79 @@ ;; 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)) + `(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)))) + ,@case-clauses)))) (defvar *smtp-debug* nil) (defun send-letter (server from to message - &key cc bcc subject reply-to headers) + &key cc bcc subject reply-to headers) ;; ;; see documentation at the head of this file ;; (let ((header (make-string-output-stream)) - (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)))) + (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)))) (format header "From: ~a~c~cTo: " - from - #\return - #\linefeed) + from + #\return + #\linefeed) (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed) - (if* ccs + (if* ccs then (format header "Cc: ~{ ~a~^,~}~c~c" ccs #\return #\linefeed)) - + (if* subject then (format header "Subject: ~a~c~c" subject #\return #\linefeed)) - + (if* reply-to then (format header "Reply-To: ~a~c~c" reply-to #\return #\linefeed)) - + (if* headers then (if* (stringp headers) - then (setq headers (list headers)) - elseif (consp headers) - thenret - else (error "Unknown headers format: ~s." headers)) - (dolist (h headers) - (format header "~a~c~c" h #\return #\linefeed))) - + then (setq headers (list headers)) + elseif (consp headers) + thenret + else (error "Unknown headers format: ~s." headers)) + (dolist (h headers) + (format header "~a~c~c" h #\return #\linefeed))) + (format header "~c~c" #\return #\linefeed) - + (send-smtp server from (append tos ccs bccs) - (get-output-stream-string header) - message))) - - - - + (get-output-stream-string header) + message))) + + + + (defun send-smtp (server from to &rest messages) ;; send the effective concatenation of the messages via @@ -172,179 +172,179 @@ ;; (let ((sock (connect-to-mail-server server))) - + (unwind-protect - (progn - - (smtp-command sock "MAIL from:<~a>" from) - (response-case (sock msg) - (2 ;; cool - nil - ) - (t (error "Mail from command failed: ~s" msg))) - - (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-command sock "RCPT to:<~a>" to) - (response-case (sock msg) - (2 ;; cool - nil - ) - (t (error "rcpt to command failed: ~s" msg))))) - - (smtp-command sock "DATA") - (response-case (sock msg) - (3 ;; cool - nil) - (t (error "Data command failed: ~s" msg))) - - - - (let ((at-bol t) - (prev-ch nil)) - (dolist (message messages) - (dotimes (i (length message)) - (let ((ch (aref message i))) - (if* (and at-bol (eq ch #\.)) - then ; to prevent . from being interpreted as eol - (write-char #\. sock)) - (if* (eq ch #\newline) - then (setq at-bol t) - (if* (not (eq prev-ch #\return)) - then (write-char #\return sock)) - else (setq at-bol nil)) - (write-char ch sock) - (setq prev-ch ch))))) - - (write-char #\return sock) (write-char #\linefeed sock) - (write-char #\. sock) - (write-char #\return sock) (write-char #\linefeed sock) - - (response-case (sock msg) - (2 nil ; (format t "Message sent to ~a~%" to) - ) - - (t (error "message not sent: ~s" msg))) - - (force-output t) - - (smtp-command sock "QUIT") - (response-case (sock msg) - (2 ;; cool - nil) - (t (error "quit failed: ~s" msg)))) + (progn + + (smtp-command sock "MAIL from:<~a>" from) + (response-case (sock msg) + (2 ;; cool + nil + ) + (t (error "Mail from command failed: ~s" msg))) + + (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-command sock "RCPT to:<~a>" to) + (response-case (sock msg) + (2 ;; cool + nil + ) + (t (error "rcpt to command failed: ~s" msg))))) + + (smtp-command sock "DATA") + (response-case (sock msg) + (3 ;; cool + nil) + (t (error "Data command failed: ~s" msg))) + + + + (let ((at-bol t) + (prev-ch nil)) + (dolist (message messages) + (dotimes (i (length message)) + (let ((ch (aref message i))) + (if* (and at-bol (eq ch #\.)) + then ; to prevent . from being interpreted as eol + (write-char #\. sock)) + (if* (eq ch #\newline) + then (setq at-bol t) + (if* (not (eq prev-ch #\return)) + then (write-char #\return sock)) + else (setq at-bol nil)) + (write-char ch sock) + (setq prev-ch ch))))) + + (write-char #\return sock) (write-char #\linefeed sock) + (write-char #\. sock) + (write-char #\return sock) (write-char #\linefeed sock) + + (response-case (sock msg) + (2 nil ; (format t "Message sent to ~a~%" to) + ) + + (t (error "message not sent: ~s" msg))) + + (force-output t) + + (smtp-command sock "QUIT") + (response-case (sock msg) + (2 ;; cool + nil) + (t (error "quit failed: ~s" msg)))) (close sock)))) (defun connect-to-mail-server (server) ;; make that initial connection to the mail server - ;; returning a socket connected to it and + ;; returning a socket connected to it and ;; signaling an error if it can't be made. (let ((ipaddr (determine-mail-server server)) - (sock) - (ok)) - + (sock) + (ok)) + (if* (null ipaddr) then (error "Can't determine ip addres for mail server ~s" server)) - + (setq sock (make-socket :remote-host #+allegro ipaddr #-allegro server - :remote-port 25 ; smtp - )) + :remote-port 25 ; smtp + )) (unwind-protect - (progn - (response-case (sock msg) - (2 ;; to the initial connect - nil) - (t (error "initial connect failed: ~s" msg))) - - ;; now that we're connected we can compute our hostname - (let ((hostname (ipaddr-to-hostname - (local-host sock)))) - (if* (null hostname) - then (setq hostname - (format nil "[~a]" (ipaddr-to-dotted - (local-host sock))))) - (smtp-command sock "HELO ~a" hostname) - (response-case (sock msg) - (2 ;; ok - nil) - (t (error "hello greeting failed: ~s" msg)))) - - ; all is good - (setq ok t)) - + (progn + (response-case (sock msg) + (2 ;; to the initial connect + nil) + (t (error "initial connect failed: ~s" msg))) + + ;; now that we're connected we can compute our hostname + (let ((hostname (ipaddr-to-hostname + (local-host sock)))) + (if* (null hostname) + then (setq hostname + (format nil "[~a]" (ipaddr-to-dotted + (local-host sock))))) + (smtp-command sock "HELO ~a" hostname) + (response-case (sock msg) + (2 ;; ok + nil) + (t (error "hello greeting failed: ~s" msg)))) + + ; all is good + (setq ok t)) + ; cleanup: - (if* (null ok) - then (close sock :abort t) - (setq sock nil))) - + (if* (null ok) + then (close sock :abort t) + (setq sock nil))) + ; return: 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))) + (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") + 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))))) - + (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)))) (if* (null sock) then (return-from test-email-address nil)) - + (unwind-protect - (progn - (smtp-command sock "VRFY ~a" name) - (response-case (sock msg code) - (5 - (if* (eq code 550) - then ; no such user - msg ; to remove unused warning - nil - else t ; otherwise we don't know - )) - (t t))) - (close sock :abort t))))) - - - - - - - - - - - - - - - + (progn + (smtp-command sock "VRFY ~a" name) + (response-case (sock msg code) + (5 + (if* (eq code 550) + then ; no such user + msg ; to remove unused warning + nil + else t ; otherwise we don't know + )) + (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 + ;; 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. @@ -352,18 +352,18 @@ ;; 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))))) + ;; 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))) + :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))) + 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: @@ -375,40 +375,40 @@ ;; (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)))) + 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)))))))) + (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*)) + (force-output *smtp-debug*)) (write-string command stream) (write-char #\return stream) (write-char #\newline stream) @@ -423,60 +423,60 @@ (loop (setq ch (read-char stream nil nil)) (if* (null ch) - then ; premature eof - (return nil)) + then ; premature eof + (return nil)) (if* *smtp-debug* - then (format *smtp-debug* "~c" ch) - (force-output *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)) + 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) + 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)) + then (vector-push-extend ch res)) (setq last-ch ch)))) (defun determine-mail-server (name) - ;; return the ipaddress to be used to connect to the + ;; return the ipaddress to be used to connect to the ;; the mail server. ;; name is any method for naming a machine: ;; integer ip address ;; string with dotted ip address ;; string naming a machine - ;; we can only do the mx lookup for the third case, the rest + ;; 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* (integerp name) then name elseif (integerp (setq ipaddr - (dotted-to-ipaddr name :errorp nil))) + (dotted-to-ipaddr name :errorp nil))) then ipaddr else ; do mx lookup if acldns is being used #+allegro (if* (or (eq *dns-mode* :acldns) - (member :acldns *dns-mode* :test #'eq)) - then (let ((res (dns-query name :type :mx))) - (if* (and res (consp res)) - then (cadr res) ; the ip address - else (dns-query name :type :a))) - else ; just do a hostname lookup - (ignore-errors (lookup-hostname name))) + (member :acldns *dns-mode* :test #'eq)) + then (let ((res (dns-query name :type :mx))) + (if* (and res (consp res)) + then (cadr res) ; the ip address + else (dns-query name :type :a))) + else ; just do a hostname lookup + (ignore-errors (lookup-hostname name))) #-allegro (ignore-errors (lookup-hostname name)) )) ) - - - + + + (provide :smtp)