From 554f039600b5c30f84b71b1f7ed2e902d5097e9b Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 10 Oct 2002 00:13:38 +0000 Subject: [PATCH] r2962: *** empty log message *** --- debian/cl-postoffice.doc-base | 12 + imap.cl => imap.lisp | 78 +----- package.lisp | 71 +++++ smtp.cl | 481 ---------------------------------- 4 files changed, 91 insertions(+), 551 deletions(-) create mode 100644 debian/cl-postoffice.doc-base rename imap.cl => imap.lisp (97%) create mode 100644 package.lisp delete mode 100644 smtp.cl diff --git a/debian/cl-postoffice.doc-base b/debian/cl-postoffice.doc-base new file mode 100644 index 0000000..59e6e8e --- /dev/null +++ b/debian/cl-postoffice.doc-base @@ -0,0 +1,12 @@ +Document: cl-postoffice +Title: CL-Postoffice Manual +Author: Franz, Inc. +Abstract: This manual describes the + use the Post Office Common Lisp library. This library provides + client access to SMTP, POP, and IMAP servers from Common Lisp + programs. +Section: programming + +Format: HTML +Index: /usr/share/doc/cl-postoffice/postoffice.html +Files: /usr/share/doc/cl-postoffice/*.html diff --git a/imap.cl b/imap.lisp similarity index 97% rename from imap.cl rename to imap.lisp index 101c4e4..01597e8 100644 --- a/imap.cl +++ b/imap.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: imap.cl,v 1.1 2002/10/09 14:26:11 kevin Exp $ +;; $Id: imap.lisp,v 1.1 2002/10/10 00:12:45 kevin Exp $ ;; Description: ;; @@ -29,68 +29,6 @@ ;;- -(defpackage :net.post-office - (:use :lisp :excl) - (:export - #:address-name - #:address-additional - #:address-mailbox - #:address-host - - #:alter-flags - #:close-connection - #:close-mailbox - #:copy-to-mailbox - #:create-mailbox - #:delete-letter - #:delete-mailbox - - #:envelope-date - #:envelope-subject - #:envelope-from - #:envelope-sender - #:envelope-reply-to - #:envelope-to - #:envelope-cc - #:envelope-bcc - #:envelope-in-reply-to - #:envelope-message-id - - #:expunge-mailbox - #:fetch-field - #:fetch-letter - #:fetch-parts - #:*imap-version-number* - #:make-envelope-from-text - #:mailbox-flags ; accessor - #:mailbox-permanent-flags ; acc - #:mailbox-list - #:mailbox-list-flags - #:mailbox-list-separator - #:mailbox-list-name - #:mailbox-message-count ; accessor - #:mailbox-recent-messages ; ac - #:mailbox-separator ; accessor - #:mailbox-uidvalidity - #:make-imap-connection - #:make-pop-connection - #:noop - #:parse-mail-header - #:top-lines ; pop only - #:unique-id ; pop only - - #:po-condition - #:po-condition-identifier - #:po-condition-server-string - #:po-error - - #:rename-mailbox - #:search-mailbox - #:select-mailbox - - ) - ) - (in-package :net.post-office) (provide :imap) @@ -348,7 +286,7 @@ user password (timeout 30)) - (let* ((sock (socket:make-socket :remote-host host + (let* ((sock (make-socket :remote-host host :remote-port port)) (imap (make-instance 'imap-mailbox :socket sock @@ -423,7 +361,7 @@ user password (timeout 30)) - (let* ((sock (socket:make-socket :remote-host host + (let* ((sock (make-socket :remote-host host :remote-port port)) (pop (make-instance 'pop-mailbox :socket sock @@ -1719,7 +1657,7 @@ ; this used to be exported from the excl package -#+(version>= 6 0) +#+(and allegro (version>= 6 0)) (defvar *keyword-package* (find-package :keyword)) @@ -1802,7 +1740,7 @@ (block timeout - (mp:with-timeout ((timeout mailbox) + (with-timeout ((timeout mailbox) (po-error :timeout :format-control "imap server failed to respond")) ;; read up to lf (lf most likely preceeded by cr) @@ -1875,7 +1813,7 @@ (let ((buff (get-line-buffer count)) (p (post-office-socket mb)) (ind 0)) - (mp:with-timeout ((timeout mb) + (with-timeout ((timeout mb) (po-error :timeout :format-control "imap server timed out")) @@ -1895,7 +1833,7 @@ (defun get-line-buffer (size) ;; get a buffer of at least size bytes (setq size (min size (1- array-total-size-limit))) - (mp::without-scheduling + (:without-scheduling (dolist (buff *line-buffers* (make-string size)) (if* (>= (length buff) size) then ; use this one @@ -1904,7 +1842,7 @@ (defun free-line-buffer (buff) - (mp:without-scheduling + (without-scheduling (push buff *line-buffers*))) (defun init-line-buffer (new old) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..8f4352b --- /dev/null +++ b/package.lisp @@ -0,0 +1,71 @@ +(defpackage :net.post-office + (:use :lisp :excl + #-allegro :acl-socket + #+allegro :socket + #-allegro :acl-compat-mp + #+allegro :mp) + (:export + ;; From smtp.lisp + #:send-letter + #:send-smtp + #:test-email-address + + ;; From imap.lisp + + #:address-name + #:address-additional + #:address-mailbox + #:address-host + + #:alter-flags + #:close-connection + #:close-mailbox + #:copy-to-mailbox + #:create-mailbox + #:delete-letter + #:delete-mailbox + + #:envelope-date + #:envelope-subject + #:envelope-from + #:envelope-sender + #:envelope-reply-to + #:envelope-to + #:envelope-cc + #:envelope-bcc + #:envelope-in-reply-to + #:envelope-message-id + + #:expunge-mailbox + #:fetch-field + #:fetch-letter + #:fetch-parts + #:*imap-version-number* + #:make-envelope-from-text + #:mailbox-flags ; accessor + #:mailbox-permanent-flags ; acc + #:mailbox-list + #:mailbox-list-flags + #:mailbox-list-separator + #:mailbox-list-name + #:mailbox-message-count ; accessor + #:mailbox-recent-messages ; ac + #:mailbox-separator ; accessor + #:mailbox-uidvalidity + #:make-imap-connection + #:make-pop-connection + #:noop + #:parse-mail-header + #:top-lines ; pop only + #:unique-id ; pop only + + #:po-condition + #:po-condition-identifier + #:po-condition-server-string + #:po-error + + #:rename-mailbox + #:search-mailbox + #:select-mailbox + + )) 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) -- 2.34.1