X-Git-Url: http://git.kpe.io/?p=postoffice.git;a=blobdiff_plain;f=smtp.cl;fp=smtp.cl;h=0000000000000000000000000000000000000000;hp=d6a2217800ebd72714f454688ec799ef94aeb59a;hb=554f039600b5c30f84b71b1f7ed2e902d5097e9b;hpb=81acb4be0ab6aee57b87b724817729cd6394bc52 diff --git a/smtp.cl b/smtp.cl deleted file mode 100644 index d6a2217..0000000 --- a/smtp.cl +++ /dev/null @@ -1,481 +0,0 @@ -;; -*- mode: common-lisp; package: net.post-office -*- -;; -;; smtp.cl -;; -;; 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 Free Software Foundation, as clarified by the AllegroServe -;; prequel found in license-allegroserve.txt. -;; -;; This code is distributed in the hope that it will be useful, -;; but without any warranty; without even the implied warranty of -;; 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 -;; 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, -;; Suite 330, Boston, MA 02111-1307 USA -;; -;; -;; $Id: smtp.cl,v 1.1 2002/10/09 14:26:11 kevin Exp $ - -;; Description: -;; send mail to an smtp server. See rfc821 for the spec. - -;;- This code in this file obeys the Lisp Coding Standard found in -;;- http://www.franz.com/~jkf/coding_standards.html -;;- - - -(defpackage :net.post-office - (:use #:lisp #:excl) - (:export - #:send-letter - #:send-smtp - #:test-email-address)) - -(in-package :net.post-office) - - -;; 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 -;; 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 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)))) - -(defvar *smtp-debug* nil) - - - -(defun send-letter (server from to message - &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)))) - (format header "From: ~a~c~cTo: " - from - #\return - #\linefeed) - (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed) - (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))) - - (format header "~c~c" #\return #\linefeed) - - (send-smtp server from (append tos ccs bccs) - (get-output-stream-string header) - message))) - - - - - -(defun send-smtp (server from to &rest messages) - ;; send the effective concatenation of the messages via - ;; smtp to the mail server - ;; Each message should be a string - ;; - ;; '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))) - - (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)))) - (close sock)))) - -(defun connect-to-mail-server (server) - ;; 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 ((ipaddr (determine-mail-server server)) - (sock) - (ok)) - - (if* (null ipaddr) - then (error "Can't determine ip addres for mail server ~s" server)) - - (setq sock (socket:make-socket :remote-host ipaddr - :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 (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))))) - (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))) - - ; 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))) - 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)))) - (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))))) - - - - - - - - - - - - - - - -(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)))) - - -(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: - ;; 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 just return the ipaddress for what we were given - ;; - (let (ipaddr) - (if* (integerp name) - then name - elseif (integerp (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) - (member :acldns socket:*dns-mode* :test #'eq)) - then (let ((res (socket:dns-query name :type :mx))) - (if* (and res (consp res)) - then (cadr res) ; the ip address - else (socket:dns-query name :type :a))) - else ; just do a hostname lookup - (ignore-errors (socket:lookup-hostname name)))))) - - - -(provide :smtp)