From 3982daabce7eab2cac2fad524e3bae9c3fec3fef Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 9 Oct 2002 14:30:57 +0000 Subject: [PATCH] r2958: *** empty log message *** --- ChangeLog | 90 ++ debian/changelog | 6 + debian/control | 14 + debian/copyright | 90 ++ debian/docs | 1 + debian/postinst | 52 ++ debian/postoffice.asd | 42 + debian/prerm | 42 + debian/rules | 81 ++ imap.cl | 1942 +++++++++++++++++++++++++++++++++++++++++ postoffice.html | 1214 ++++++++++++++++++++++++++ smtp.cl | 481 ++++++++++ smtp.lisp | 489 +++++++++++ 13 files changed, 4544 insertions(+) create mode 100644 ChangeLog create mode 100644 debian/changelog create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/docs create mode 100644 debian/postinst create mode 100644 debian/postoffice.asd create mode 100644 debian/prerm create mode 100755 debian/rules create mode 100644 imap.cl create mode 100644 postoffice.html create mode 100644 smtp.cl create mode 100644 smtp.lisp diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..420f1bd --- /dev/null +++ b/ChangeLog @@ -0,0 +1,90 @@ +2001-08-20 John Foderaro + + * imap.cl (parse-mail-header): fix parse when a #\return was found + in the header. [bug11124] + +******************************************************************************* +merge from trunk to acl61 branch +command: ../../join.sh trunk acl61 trunk_to_acl61_merge1 imap +******************************************************************************* + +2001-08-10 John Foderaro + + * imap.cl - fix problems of too many #\returns in the header + +2001-06-26 John Foderaro + + * imap.cl - fix typo in exported identifier + +2001-05-11 John Foderaro + + * smtp.cl: add test-email-address function to check to see + if an email address can be determined to be bogus without + sending a letter. + +2001-05-02 John Foderaro +1.8 + * imap will signal a :response-too-large error if it encounter + a letter it can't store in a lisp array. + +2000-06-08 +1.7 + * imap.cl: add parse-mail-header function to return mail headers + as an assoc list. + +2000-06-06 John Foderaro +1.6 + * imap.cl: fix header parsing bug where it go into a loop + when encountering a blank header. + +Fri May 26 22:52:42 PST 2000 Duane Rettig + + * makefile: set SHELL variable + +2000-04-26 John Foderaro + + * package changed from post-office to net.post-office + the po nickname was removed. + + +2000-04-21 John Foderaro +versio 1.4 + * imap.cl: added pop commands unique-id and top-lines + plus make-envelope-from-text + + * imap.html - update document + + +1999-11-29 John Foderaro +version 1.3 + * imap.cl - fixed bug where extra ^b's ended up in strings + * imap.html - fixed ref to wrong function + +1999-10-27 John Foderaro +version 1.2 + + * imap.cl - add condtions + * imap.html - document conditions + * t-imap.cl - fix test suite + + +1999-09-29 John Foderaro +version 1.1 + + * imap.html - document send-letter, send-smtp + * smtp.cl - add this to the imap module + * t-imap.cl - adjust for the change in package + + + +1999-09-27 John Foderaro +version 1.0 + * start ChangeLog. + * imap.cl - the code for the imap and pop interface + * imap.html - the documentation + * t-imap.cl - the test suite + * rfc1939.html - pop spec + * rfc2060.txt - imap spec + + + diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..3644522 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +cl-smtp (1.0-1) unstable; urgency=low + + * Initial Release (closes: #) + + -- Kevin M. Rosenberg Wed, 9 Oct 2002 04:30:08 -0600 + diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..2ee0873 --- /dev/null +++ b/debian/control @@ -0,0 +1,14 @@ +Source: cl-postoffice +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends: debhelper (>= 4.0.0) +Standards-Version: 3.5.7.0 + +Package: cl-postoffice +Architecture: all +Depends: ${shlibs:Depends}, cl-acl-compat +Description: SMTP, POP, & IMAP interface library for Common Lisp Programs + This is a Franz's open-source Postoffice package which includes + libraries for SMTP, POP, and IMAP clients. This package uses the + ACL-COMPAT module for operation on non-Allegro Common Lisp implementations. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..4e0efe9 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,90 @@ +This package was debianized by Kevin M. Rosenberg on +Wed, 9 Oct 2002 04:30:08 -0600. + +It was downloaded from http://opensource.franz.com/smtp/ + +Upstream Author(s): Franz, Inc. + +Changes compared to upstream version: + Use ACL-COMPAT socket routines + + +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 Franz preamble to the LGPL found in +http://opensource.franz.com/preamble.html. The preambled is copied below. + +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. + +The GNU Lessor General Public License can be found in your Debian file +system in /usr/share/common-licenses/LGPL. + +Preamble to the Gnu Lesser General Public License +------------------------------------------------- +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 +("LGPL") has been adopted to govern the use and distribution of +above-mentioned application. However, the LGPL uses terminology that +is more appropriate for a program written in C than one written in +Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if +certain clarifications are made. This document details those +clarifications. Accordingly, the license for the open-source Lisp +applications consists of this document plus the LGPL. Wherever there +is a conflict between this document and the LGPL, this document takes +precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and +foreign modules. The form of the Library can be Lisp source code (for +processing by an interpreter) or object code (usually the result of +compilation of source code or built with some other +mechanisms). Foreign modules are object code in a form that can be +linked into a Lisp executable. When we speak of functions we do so in +the most general way to include, in addition, methods and unnamed +functions. Lisp "data" is also a general term that includes the data +structures resulting from defining Lisp classes. A Lisp application +may include the same set of Lisp objects as does a Library, but this +does not mean that the application is necessarily a "work based on the +Library" it contains. + +The Library consists of everything in the distribution file set before +any modifications are made to the files. If any of the functions or +classes in the Library are redefined in other files, then those +redefinitions ARE considered a work based on the Library. If +additional methods are added to generic functions in the Library, +those additional methods are NOT considered a work based on the +Library. If Library classes are subclassed, these subclasses are NOT +considered a work based on the Library. If the Library is modified to +explicitly call other functions that are neither part of Lisp itself +nor an available add-on module to Lisp, then the functions called by +the modified Library ARE considered a work based on the Library. The +goal is to ensure that the Library will compile and run without +getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it +must be done in a way such that the Library will still run without +that proprietary code present. Section 5 of the LGPL distinguishes +between the case of a library being dynamically linked at runtime and +one being statically linked at build time. Section 5 of the LGPL +states that the former results in an executable that is a "work that +uses the Library." Section 5 of the LGPL states that the latter +results in one that is a "derivative of the Library", which is +therefore covered by the LGPL. Since Lisp only offers one choice, +which is to link the Library into an executable at build time, we +declare that, for the purpose applying the LGPL to the Library, an +executable that results from linking a "work that uses the Library" +with the Library is considered a "work that uses the Library" and is +therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to +the Library. However, in connection with each distribution of this +executable, you must also deliver, in accordance with the terms and +conditions of the LGPL, the source code of Library (or your derivative +thereof) that is incorporated into this executable. + diff --git a/debian/docs b/debian/docs new file mode 100644 index 0000000..56631ab --- /dev/null +++ b/debian/docs @@ -0,0 +1 @@ +ChangeLog diff --git a/debian/postinst b/debian/postinst new file mode 100644 index 0000000..0991b64 --- /dev/null +++ b/debian/postinst @@ -0,0 +1,52 @@ +#! /bin/sh +# postinst script for postoffice +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=postoffice + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + #clc-only-compatible $LISP_PKG allegro cmucl lispworks openmcl + /usr/sbin/register-common-lisp-source $LISP_PKG + ;; + + abort-upgrade|abort-remove|abort-deconfigure) + + ;; + + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/postoffice.asd b/debian/postoffice.asd new file mode 100644 index 0000000..bbeaef2 --- /dev/null +++ b/debian/postoffice.asd @@ -0,0 +1,42 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postoffice.asd +;;;; Purpose: ASDF definition file for Postoffice +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2002 +;;;; +;;;; $Id: postoffice.asd,v 1.1 2002/10/09 14:25:14 kevin Exp $ +;;;; +;;;; This file, part of cl-postoffice, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; cl-postoffice users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU Lesser General Public License +;;;; (http://www.gnu.org/licenses/lgpl.html) +;;;; ************************************************************************* + +(in-package :asdf) + +(defsystem :postoffice + :name "cl-postoffice" + :author "Kevin Layer, Franz, Inc" + :version "2.2.12.2.6.1" + :maintainer "Kevin M. Rosenberg " + :licence "GNU Lesser General Public License" + :description "Franz's Post Office Package" + :long-description "Post Office provides an interface to the SMTP, POP, and IMAP servers. It uses the ACL-COMPAT library for use with non-Allegro CL implementations." + + :perform (load-op :after (op postoffice) + (pushnew :postoffice cl:*features*)) + + :components + ((:file "smtp") + (:file "imap")) + #-allegro :depends-on #-allegro (:acl-compat) + ) + +(when (ignore-errors (find-class 'load-compiled-op)) + (defmethod perform :after ((op load-compiled-op) (c (eql (find-system :postoffice)))) + (pushnew :postoffice cl:*features*))) + diff --git a/debian/prerm b/debian/prerm new file mode 100644 index 0000000..5b04dbc --- /dev/null +++ b/debian/prerm @@ -0,0 +1,42 @@ +#! /bin/sh +# prerm script for postoffice +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=postoffice + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source $LISP_PKG + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..0547d22 --- /dev/null +++ b/debian/rules @@ -0,0 +1,81 @@ +#!/usr/bin/make -f + +export DH_COMPAT=4 + +pkg := postoffice +debpkg := cl-postoffice + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-postoffice := $(clc-source)/$(pkg) + +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -f debian/cl-postoffice.postinst.* debian/cl-postoffice.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/postoffice. + dh_installdirs $(clc-systems) $(clc-postoffice) $(doc-dir) + dh_install debian/postoffice.asd $(shell echo *.lisp) $(clc-postoffice) + dh_link $(clc-postoffice)/postoffice.asd $(clc-systems)/postoffice.asd + +# Build architecture-independent files here. +binary-indep: build install + + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installman +# dh_installinfo +# dh_undocumented + dh_installchangelogs + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/imap.cl b/imap.cl new file mode 100644 index 0000000..101c4e4 --- /dev/null +++ b/imap.cl @@ -0,0 +1,1942 @@ +;; -*- mode: common-lisp; package: net.post-office -*- +;; +;; imap.cl +;; imap and pop interface +;; +;; copyright (c) 1999 Franz Inc, Berkeley, CA - All rights reserved. +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; 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 $ + +;; Description: +;; +;; +;;- 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 + #: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) + +(defparameter *imap-version-number* '(:major 1 :minor 8)) ; major.minor + +;; todo +;; have the list of tags selected done on a per connection basis to +;; eliminate any possible multithreading problems +;; +;; + +(defvar *debug-imap* nil) + + + + + +(defclass post-office () + ((socket :initarg :socket + :accessor post-office-socket) + + (host :initarg :host + :accessor post-office-host + :initform nil) + (user :initarg :user + :accessor post-office-user + :initform nil) + + (state :accessor post-office-state + :initarg :state + :initform :unconnected) + + (timeout + ;; time to wait for network activity for actions that should + ;; happen very quickly when things are operating normally + :initarg :timeout + :initform 60 + :accessor timeout) + )) + +(defclass imap-mailbox (post-office) + ((mailbox-name ; currently selected mailbox + :accessor mailbox-name + :initform nil) + + (separator + ;; string that separates mailbox names in the hierarchy + :accessor mailbox-separator + :initform "") + + ;;; these slots hold information about the currently selected mailbox: + + (message-count ; how many in the mailbox + :accessor mailbox-message-count + :initform 0) + + (recent-messages ; how many messages since we last checked + :accessor mailbox-recent-messages + :initform 0) + + (uidvalidity ; used to denote messages uniquely + :accessor mailbox-uidvalidity + :initform 0) + + (uidnext + :accessor mailbox-uidnext ;; predicted next uid + :initform 0) + + (flags ; list of flags that can be stored in a message + :accessor mailbox-flags + :initform nil) + + (permanent-flags ; list of flags that be stored permanently + :accessor mailbox-permanent-flags + :initform nil) + + (first-unseen ; number of the first unseen message + :accessor first-unseen + :initform 0) + + ;;; end list of values for the currently selected mailbox + ) + ) + + +(defclass pop-mailbox (post-office) + ((message-count ; how many in the mailbox + :accessor mailbox-message-count + :initform 0))) + + + +(defstruct (mailbox-list (:type list)) + ;; a list of these are returned by mailbox-list + flags + separator + name) + + + +(defstruct (envelope (:type list)) + ;; returned by fetch-letter as the value of the envelope property + date + subject + from + sender + reply-to + to + cc + bcc + in-reply-to + message-id) + + +(defstruct (address (:type list)) + name ;; often the person's full name + additional + mailbox ;; the login name + host ;; the name of the machine + ) + + + +;-------------------------------- +; conditions +; +; We define a set of conditions that are signalled due to events +; in the imap interface. +; Each condition has an indentifier which is a keyword. That can +; be used in the handling code to identify the class of error. +; All our conditions are po-condition or po-error (which is a subclass of +; po-condition). +; +; A condition will have a server-string value if it as initiated by +; something returned by the server. +; A condition will have a format-control value if we want to display +; something we generated in response to +; +; +; +;; identifiers used in conditions/errors + +; :problem condition +; the server responded with 'no' followed by an explanation. +; this mean that something unusual happend and doesn't necessarily +; mean that the command has completely failed (but it might). +; +; :unknown-ok condition +; the server responded with an 'ok' followed by something +; we don't recognize. It's probably safe to ignore this. +; +; :unknown-untagged condition +; the server responded with some untagged command we don't +; recognize. it's probaby ok to ignore this. +; +; :error-response error +; the command failed. +; +; :syntax-error error +; the data passed to a function in this interface was malformed +; +; :unexpected error +; the server responded an unexpected way. +; +; :server-shutdown-connection error +; the server has shut down the connection, don't attempt to +; send any more commands to this connection, or even close it. +; +; :timeout error +; server failed to respond within the timeout period +; +; :response-too-large error +; contents of a response is too large to store in a Lisp array. + + +;; conditions +(define-condition po-condition () + ;; used to notify user of things that shouldn't necessarily stop + ;; program flow + ((identifier + ;; keyword identifying the error (or :unknown) + :reader po-condition-identifier + :initform :unknown + :initarg :identifier + ) + (server-string + ;; message from the imap server + :reader po-condition-server-string + :initform "" + :initarg :server-string + )) + (:report + (lambda (con stream) + (with-slots (identifier server-string) con + ;; a condition either has a server-string or it has a + ;; format-control string + (format stream "Post Office condition: ~s~%" identifier) + (if* (and (slot-boundp con 'excl::format-control) + (excl::simple-condition-format-control con)) + then (apply #'format stream + (excl::simple-condition-format-control con) + (excl::simple-condition-format-arguments con))) + (if* server-string + then (format stream + "~&Message from server: ~s" + (string-left-trim " " server-string))))))) + + + +(define-condition po-error (po-condition error) + ;; used to denote things that should stop program flow + ()) + + + +;; aignalling the conditions + +(defun po-condition (identifier &key server-string format-control + format-arguments) + (signal (make-instance 'po-condition + :identifier identifier + :server-string server-string + :format-control format-control + :format-arguments format-arguments + ))) + +(defun po-error (identifier &key server-string + format-control format-arguments) + (error (make-instance 'po-error + :identifier identifier + :server-string server-string + :format-control format-control + :format-arguments format-arguments))) + + + +;---------------------------------------------- + + + + + + +(defparameter *imap-tags* '("t01" "t02" "t03" "t04" "t05" "t06" "t07")) +(defvar *cur-imap-tags* nil) + +(defvar *crlf* + (let ((str (make-string 2))) + (setf (aref str 0) #\return) + (setf (aref str 1) #\linefeed) + str)) + +(defun make-imap-connection (host &key (port 143) + user + password + (timeout 30)) + (let* ((sock (socket:make-socket :remote-host host + :remote-port port)) + (imap (make-instance 'imap-mailbox + :socket sock + :host host + :timeout timeout + :state :unauthorized))) + + (multiple-value-bind (tag cmd count extra comment) + (get-and-parse-from-imap-server imap) + (declare (ignore cmd count extra)) + (if* (not (eq :untagged tag)) + then (po-error :error-response + :server-string comment))) + + ; now login + (send-command-get-results imap + (format nil "login ~a ~a" user password) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success mb command count extra + comment + "login"))) + + ; find the separator character + (let ((res (mailbox-list imap))) + ;; + (let ((sep (cadr (car res)))) + (if* sep + then (setf (mailbox-separator imap) sep)))) + + + + imap)) + + +(defmethod close-connection ((mb imap-mailbox)) + + (let ((sock (post-office-socket mb))) + (if* sock + then (ignore-errors + (send-command-get-results + mb + "logout" + ; don't want to get confused by untagged + ; bye command, which is expected here + #'(lambda (mb command count extra) + (declare (ignore mb command count extra)) + nil) + #'(lambda (mb command count extra comment) + (check-for-success mb command count extra + comment + "logout"))))) + (setf (post-office-socket mb) nil) + (if* sock then (ignore-errors (close sock))) + t)) + + +(defmethod close-connection ((pb pop-mailbox)) + (let ((sock (post-office-socket pb))) + (if* sock + then (ignore-errors + (send-pop-command-get-results + pb + "QUIT"))) + (setf (post-office-socket pb) nil) + (if* sock then (ignore-errors (close sock))) + t)) + + + +(defun make-pop-connection (host &key (port 110) + user + password + (timeout 30)) + (let* ((sock (socket:make-socket :remote-host host + :remote-port port)) + (pop (make-instance 'pop-mailbox + :socket sock + :host host + :timeout timeout + :state :unauthorized))) + + (multiple-value-bind (result) + (get-and-parse-from-pop-server pop) + (if* (not (eq :ok result)) + then (po-error :error-response + :format-control + "unexpected line from server after connect"))) + + ; now login + (send-pop-command-get-results pop (format nil "user ~a" user)) + (send-pop-command-get-results pop (format nil "pass ~a" password)) + + (let ((res (send-pop-command-get-results pop "stat"))) + (setf (mailbox-message-count pop) (car res))) + + + + pop)) + + +(defmethod send-command-get-results ((mb imap-mailbox) + command untagged-handler tagged-handler) + ;; send a command and retrieve results until we get the tagged + ;; response for the command we sent + ;; + (let ((tag (get-next-tag))) + (format (post-office-socket mb) + "~a ~a~a" tag command *crlf*) + (force-output (post-office-socket mb)) + + (if* *debug-imap* + then (format t + "~a ~a~a" tag command *crlf*) + (force-output)) + (loop + (multiple-value-bind (got-tag cmd count extra comment) + (get-and-parse-from-imap-server mb) + (if* (eq got-tag :untagged) + then (funcall untagged-handler mb cmd count extra comment) + elseif (equal tag got-tag) + then (funcall tagged-handler mb cmd count extra comment) + (return) + else (po-error :error-response + :format-control "received tag ~s out of order" + :format-arguments (list got-tag) + :server-string comment)))))) + + +(defun get-next-tag () + (let ((tag (pop *cur-imap-tags*))) + (if* tag + thenret + else (setq *cur-imap-tags* *imap-tags*) + (pop *cur-imap-tags*)))) + +(defun handle-untagged-response (mb command count extra comment) + ;; default function to handle untagged responses, which are + ;; really just returning general state information about + ;; the mailbox + (case command + (:exists (setf (mailbox-message-count mb) count)) + (:recent (setf (mailbox-recent-messages mb) count)) + (:flags (setf (mailbox-flags mb) (mapcar #'kwd-intern extra))) + (:bye ; occurs when connection times out or mailbox lock is stolen + (ignore-errors (close (post-office-socket mb))) + (po-error :server-shutdown-connection + :server-string "server shut down the connection")) + (:no ; used when grabbing a lock from another process + (po-condition :problem :server-string comment)) + (:ok ; a whole variety of things + (if* extra + then (if* (equalp (car extra) "unseen") + then (setf (first-unseen mb) (cadr extra)) + elseif (equalp (car extra) "uidvalidity") + then (setf (mailbox-uidvalidity mb) (cadr extra)) + elseif (equalp (car extra) "uidnext") + then (setf (mailbox-uidnext mb) (cadr extra)) + elseif (equalp (car extra) "permanentflags") + then (setf (mailbox-permanent-flags mb) + (mapcar #'kwd-intern (cadr extra))) + else (po-condition :unknown-ok :server-string comment)))) + (t (po-condition :unknown-untagged :server-string comment))) + + ) + + + +(defun send-pop-command-get-results (pop command &optional extrap) + ;; send the given command to the pop server + ;; if extrap is true and if the response is +ok, then data + ;; will follow the command (up to and excluding the first line consisting + ;; of just a period) + ;; + ;; if the pop server returns an error code we signal a lisp error. + ;; otherwise + ;; return + ;; extrap is nil -- return the list of tokens on the line after +ok + ;; extrap is true -- return the extra object (a big string) + ;; + (format (post-office-socket pop) "~a~a" command *crlf*) + (force-output (post-office-socket pop)) + + (if* *debug-imap* + then (format t "~a~a" command *crlf*) + (force-output t)) + + (multiple-value-bind (result parsed line) + (get-and-parse-from-pop-server pop) + (if* (not (eq result :ok)) + then (po-error :error-response + :server-string line)) + + (if* extrap + then ;; get the rest of the data + ;; many but not all pop servers return the size of the data + ;; after the +ok, so we use that to initially size the + ;; retreival buffer. + (let ((buf (get-line-buffer (+ (if* (fixnump (car parsed)) + then (car parsed) + else 2048 ; reasonable size + ) + 50))) + (pos 0) + ; states + ; 1 - after lf + ; 2 - seen dot at beginning of line + ; 3 - seen regular char on line + (state 1) + (sock (post-office-socket pop))) + (flet ((add-to-buffer (ch) + (if* (>= pos (length buf)) + then ; grow buffer + (if* (>= (length buf) + (1- array-total-size-limit)) + then ; can't grow it any further + (po-error + :response-too-large + :format-control + "response from mail server is too large to hold in a lisp array")) + (let ((new-buf (get-line-buffer + (* (length buf) 2)))) + (init-line-buffer new-buf buf) + (free-line-buffer buf) + (setq buf new-buf))) + (setf (schar buf pos) ch) + (incf pos))) + (loop + (let ((ch (read-char sock nil nil))) + (if* (null ch) + then (po-error :unexpected + :format-control "premature end of file from server")) + (if* (eq ch #\return) + thenret ; ignore crs + else (case state + (1 (if* (eq ch #\.) + then (setq state 2) + elseif (eq ch #\linefeed) + then (add-to-buffer ch) + ; state stays at 1 + else (add-to-buffer ch) + (setq state 3))) + (2 ; seen first dot + (if* (eq ch #\linefeed) + then ; end of message + (return) + else (add-to-buffer ch) + (setq state 3))) + (3 ; normal reading + (add-to-buffer ch) + (if* (eq ch #\linefeed) + then (setq state 1)))))))) + (prog1 (subseq buf 0 pos) + (free-line-buffer buf))) + else parsed))) + + + + +(defun convert-flags-plist (plist) + ;; scan the plist looking for "flags" indicators and + ;; turn value into a list of symbols rather than strings + (do ((xx plist (cddr xx))) + ((null xx) plist) + (if* (equalp "flags" (car xx)) + then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx)))))) + + +(defmethod select-mailbox ((mb imap-mailbox) name) + ;; select the given mailbox + (send-command-get-results mb + (format nil "select ~a" name) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (declare (ignore mb count extra)) + (if* (not (eq command :ok)) + then (po-error + :problem + :format-control + "imap mailbox select failed" + :server-string comment)))) + (setf (mailbox-name mb) name) + t + ) + + +(defmethod fetch-letter ((mb imap-mailbox) number &key uid) + ;; return the whole letter + (fetch-field number "body[]" + (fetch-parts mb number "body[]" :uid uid) + :uid uid)) + + +(defmethod fetch-letter ((pb pop-mailbox) number &key uid) + (declare (ignore uid)) + (send-pop-command-get-results pb + (format nil "RETR ~d" number) + t ; extra stuff + )) + +(defmethod fetch-parts ((mb imap-mailbox) number parts &key uid) + (let (res) + (send-command-get-results + mb + (format nil "~afetch ~a ~a" + (if* uid then "uid " else "") + (message-set-string number) + (or parts "body[]") + ) + #'(lambda (mb command count extra comment) + (if* (eq command :fetch) + then (push (list count (internalize-flags extra)) res) + else (handle-untagged-response + mb command count extra comment))) + #'(lambda (mb command count extra comment) + (declare (ignore mb count extra)) + (if* (not (eq command :ok)) + then (po-error :problem + :format-control "imap mailbox fetch failed" + :server-string comment)))) + res)) + + +(defun fetch-field (letter-number field-name info &key uid) + ;; given the information from a fetch-letter, return the + ;; particular field for the particular letter + ;; + ;; info is as returned by fetch + ;; field-name is a string, case doesn't matter. + ;; + (dolist (item info) + ;; item is (messagenumber plist-info) + ;; the same messagenumber may appear in multiple items + (let (use-this) + (if* uid + then ; uid appears as a property in the value, not + ; as the top level message sequence number + (do ((xx (cadr item) (cddr xx))) + ((null xx)) + (if* (equalp "uid" (car xx)) + then (if* (eql letter-number (cadr xx)) + then (return (setq use-this t)) + else (return)))) + else ; just a message sequence number + (setq use-this (eql letter-number (car item)))) + + (if* use-this + then (do ((xx (cadr item) (cddr xx))) + ((null xx)) + (if* (equalp field-name (car xx)) + then (return-from fetch-field (cadr xx)))))))) + + + +(defun internalize-flags (stuff) + ;; given a plist like object, look for items labelled "flags" and + ;; convert the contents to internal flags objects + (do ((xx stuff (cddr xx))) + ((null xx)) + (if* (equalp (car xx) "flags") + then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))) + (return))) + + stuff) + + + + +(defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid) + ;; delete all the mesasges and do the expunge to make + ;; it permanent if expunge is true + (alter-flags mb messages :add-flags :\\deleted :uid uid) + (if* expunge then (expunge-mailbox mb))) + +(defmethod delete-letter ((pb pop-mailbox) messages &key (expunge nil) uid) + ;; delete all the messages. We can't expunge without quitting so + ;; we don't expunge + (declare (ignore expunge uid)) + + (if* (or (numberp messages) + (and (consp messages) (eq :seq (car messages)))) + then (setq messages (list messages))) + + (if* (not (consp messages)) + then (po-error :syntax-error + :format-control "expect a mesage number or list of messages, not ~s" + :format-arguments (list messages))) + + (dolist (message messages) + (if* (numberp message) + then (send-pop-command-get-results pb + (format nil "DELE ~d" message)) + elseif (and (consp message) (eq :seq (car message))) + then (do ((start (cadr message) (1+ start)) + (end (caddr message))) + ((> start end)) + (send-pop-command-get-results pb + (format nil "DELE ~d" start))) + else (po-error :syntax-error + :format-control "bad message number ~s" + :format-arguments (list message))))) + + + + + +(defmethod noop ((mb imap-mailbox)) + ;; just poke the server... keeping it awake and checking for + ;; new letters + (send-command-get-results mb + "noop" + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment + "noop")))) + + +(defmethod noop ((pb pop-mailbox)) + ;; send the stat command instead so we can update the message count + (let ((res (send-pop-command-get-results pb "stat"))) + (setf (mailbox-message-count pb) (car res))) + ) + + +(defmethod unique-id ((pb pop-mailbox) &optional message) + ;; if message is given, return the unique id of that + ;; message, + ;; if message is not given then return a list of lists: + ;; (message unique-id) + ;; for all messages not marked as deleted + ;; + (if* message + then (let ((res (send-pop-command-get-results pb + (format nil + "UIDL ~d" + message)))) + (cadr res)) + else ; get all of them + (let* ((res (send-pop-command-get-results pb "UIDL" t)) + (end (length res)) + kind + mnum + mid + (next 0)) + + + (let ((coll)) + (loop + (multiple-value-setq (kind mnum next) + (get-next-token res next end)) + + (if* (eq :eof kind) then (return)) + + (if* (not (eq :number kind)) + then ; hmm. bogus + (po-error :unexpected + :format-control "uidl returned illegal message number in ~s" + :format-arguments (list res))) + + ; now get message id + + (multiple-value-setq (kind mid next) + (get-next-token res next end)) + + (if* (eq :number kind) + then ; looked like a number to the tokenizer, + ; make it a string to be consistent + (setq mid (format nil "~d" mid)) + elseif (not (eq :string kind)) + then ; didn't find the uid + (po-error :unexpected + :format-control "uidl returned illegal message id in ~s" + :format-arguments (list res))) + + (push (list mnum mid) coll)) + + (nreverse coll))))) + +(defmethod top-lines ((pb pop-mailbox) message lines) + ;; return the header and the given number of top lines of the message + + (let ((res (send-pop-command-get-results pb + (format nil + "TOP ~d ~d" + message + lines) + t ; extra + ))) + res)) + + + + + + +(defun check-for-success (mb command count extra comment command-string ) + (declare (ignore mb count extra)) + (if* (not (eq command :ok)) + then (po-error :error-response + :format-control "imap ~a failed" + :format-arguments (list command-string) + :server-string comment))) + + + + + +(defmethod mailbox-list ((mb imap-mailbox) &key (reference "") (pattern "")) + ;; return a list of mailbox names with respect to a given + (let (res) + (send-command-get-results mb + (format nil "list ~s ~s" reference pattern) + #'(lambda (mb command count extra comment) + (if* (eq command :list) + then (push extra res) + else (handle-untagged-response + mb command count extra + comment))) + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "list"))) + + ;; the car of each list is a set of keywords, make that so + (dolist (rr res) + (setf (car rr) (mapcar #'kwd-intern (car rr)))) + + res + + + )) + + +(defmethod create-mailbox ((mb imap-mailbox) mailbox-name) + ;; create a mailbox name of the given name. + ;; use mailbox-separator if you want to create a hierarchy + (send-command-get-results mb + (format nil "create ~s" mailbox-name) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "create"))) + t) + + +(defmethod delete-mailbox ((mb imap-mailbox) mailbox-name) + ;; create a mailbox name of the given name. + ;; use mailbox-separator if you want to create a hierarchy + (send-command-get-results mb + (format nil "delete ~s" mailbox-name) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "delete")))) + +(defmethod rename-mailbox ((mb imap-mailbox) old-mailbox-name new-mailbox-name) + ;; create a mailbox name of the given name. + ;; use mailbox-separator if you want to create a hierarchy + (send-command-get-results mb + (format nil "rename ~s ~s" + old-mailbox-name + new-mailbox-name) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment + "rename")))) + + + +(defmethod alter-flags ((mb imap-mailbox) + messages &key (flags nil flags-p) + add-flags remove-flags + silent uid) + ;; + ;; change the flags using the store command + ;; + (let (cmd val res) + (if* flags-p + then (setq cmd "flags" val flags) + elseif add-flags + then (setq cmd "+flags" val add-flags) + elseif remove-flags + then (setq cmd "-flags" val remove-flags) + else (return-from alter-flags nil)) + + (if* (atom val) then (setq val (list val))) + + (send-command-get-results mb + (format nil "~astore ~a ~a~a ~a" + (if* uid then "uid " else "") + (message-set-string messages) + cmd + (if* silent + then ".silent" + else "") + (if* val + thenret + else "()")) + #'(lambda (mb command count extra comment) + (if* (eq command :fetch) + then (push (list count + (convert-flags-plist + extra)) + res) + else (handle-untagged-response + mb command count extra + comment))) + + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "store"))) + res)) + + +(defun message-set-string (messages) + ;; return a string that describes the messages which may be a + ;; single number or a sequence of numbers + + (if* (atom messages) + then (format nil "~a" messages) + else (if* (and (consp messages) + (eq :seq (car messages))) + then (format nil "~a:~a" (cadr messages) (caddr messages)) + else (let ((str (make-string-output-stream)) + (precomma nil)) + (dolist (msg messages) + (if* precomma then (format str ",")) + (if* (atom msg) + then (format str "~a" msg) + elseif (eq :seq (car msg)) + then (format str + "~a:~a" (cadr msg) (caddr msg)) + else (po-error :syntax-error + :format-control "bad message list ~s" + :format-arguments (list msg))) + (setq precomma t)) + (get-output-stream-string str))))) + + + + + + +(defmethod expunge-mailbox ((mb imap-mailbox)) + ;; remove messages marked as deleted + (let (res) + (send-command-get-results mb + "expunge" + #'(lambda (mb command count extra + comment) + (if* (eq command :expunge) + then (push count res) + else (handle-untagged-response + mb command count extra + comment))) + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "expunge"))) + (nreverse res))) + + + +(defmethod close-mailbox ((mb imap-mailbox)) + ;; remove messages marked as deleted + (send-command-get-results mb + "close" + #'handle-untagged-response + + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "close"))) + t) + + + +(defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination + &key uid) + (send-command-get-results mb + (format nil "~acopy ~a ~s" + (if* uid then "uid " else "") + (message-set-string message-list) + destination) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "copy"))) + t) + + +;; search command + +(defmethod search-mailbox ((mb imap-mailbox) search-expression &key uid) + (let (res) + (send-command-get-results mb + (format nil "~asearch ~a" + (if* uid then "uid " else "") + (build-search-string search-expression)) + #'(lambda (mb command count extra comment) + (if* (eq command :search) + then (setq res (append res extra)) + else (handle-untagged-response + mb command count extra + comment))) + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "search"))) + res)) + + +(defmacro defsearchop (name &rest operands) + (if* (null operands) + then `(setf (get ',name 'imap-search-no-args) t) + else `(setf (get ',name 'imap-search-args) ',operands))) + +(defsearchop :all) +(defsearchop :answered) +(defsearchop :bcc :str) +(defsearchop :before :date) +(defsearchop :body :str) +(defsearchop :cc :str) +(defsearchop :deleted) +(defsearchop :draft) +(defsearchop :flagged) +(defsearchop :from :str) +(defsearchop :header :str :str) +(defsearchop :keyword :flag) +(defsearchop :larger :number) +(defsearchop :new) +(defsearchop :old) +(defsearchop :on :date) +(defsearchop :recent) +(defsearchop :seen) +(defsearchop :sentbefore :date) +(defsearchop :senton :date) +(defsearchop :sentsince :date) +(defsearchop :since :date) +(defsearchop :smaller :number) +(defsearchop :subject :str) +(defsearchop :text :str) +(defsearchop :to :str) +(defsearchop :uid :messageset) +(defsearchop :unanswered) +(defsearchop :undeleted) +(defsearchop :undraft) +(defsearchop :unflagged) +(defsearchop :unkeyword :flag) +(defsearchop :unseen) + + + +(defun build-search-string (search) + ;; take the lisp search form and turn it into a string that can be + ;; passed to imap + + (if* (null search) + then "" + else (let ((str (make-string-output-stream))) + (bss-int search str) + (get-output-stream-string str)))) + +(defun bss-int (search str) + ;;* it turns out that imap (on linux) is very picky about spaces.... + ;; any extra whitespace will result in failed searches + ;; + (labels ((and-ify (srch str) + (let ((spaceout nil)) + (dolist (xx srch) + (if* spaceout then (format str " ")) + (bss-int xx str) + (setq spaceout t)))) + (or-ify (srch str) + ; only binary or allowed in imap but we support n-ary + ; or in this interface + (if* (null (cdr srch)) + then (bss-int (car srch) str) + elseif (cddr srch) + then ; over two clauses + (format str "or (") + (bss-int (car srch) str) + (format str ") (") + (or-ify (cdr srch) str) + (format str ")") + else ; 2 args + (format str "or (" ) + (bss-int (car srch) str) + (format str ") (") + (bss-int (cadr srch) str) + (format str ")"))) + (set-ify (srch str) + ;; a sequence of messages + (do* ((xsrch srch (cdr xsrch)) + (val (car xsrch) (car xsrch))) + ((null xsrch)) + (if* (integerp val) + then (format str "~s" val) + elseif (and (consp val) + (eq :seq (car val)) + (eq 3 (length val))) + then (format str "~s:~s" (cadr val) (caddr val)) + else (po-error :syntax-error + :format-control "illegal set format ~s" + :format-arguments (list val))) + (if* (cdr xsrch) then (format str ",")))) + (arg-process (str args arginfo) + ;; process and print each arg to str + ;; assert (length of args and arginfo are the same) + (do* ((x-args args (cdr x-args)) + (val (car x-args) (car x-args)) + (x-arginfo arginfo (cdr x-arginfo))) + ((null x-args)) + (ecase (car x-arginfo) + (:str + ; print it as a string + (format str " \"~a\"" (car x-args))) + (:date + + (if* (integerp val) + then (setq val (universal-time-to-rfc822-date + val)) + elseif (not (stringp val)) + then (po-error :syntax-error + :format-control "illegal value for date search ~s" + :format-arguments (list val))) + ;; val is now a string + (format str " ~s" val)) + (:number + + (if* (not (integerp val)) + then (po-error :syntax-error + :format-control "illegal value for number in search ~s" + :format-arguments (list val))) + (format str " ~s" val)) + (:flag + + ;; should be a symbol in the kwd package + (setq val (string val)) + (format str " ~s" val)) + (:messageset + (if* (numberp val) + then (format str " ~s" val) + elseif (consp val) + then (set-ify val str) + else (po-error :syntax-error + :format-control "illegal message set ~s" + :format-arguments (list val)))) + + )))) + + (if* (symbolp search) + then (if* (get search 'imap-search-no-args) + then (format str "~a" (string-upcase + (string search))) + else (po-error :syntax-error + :format-control "illegal search word: ~s" + :format-arguments (list search))) + elseif (consp search) + then (case (car search) + (and (if* (null (cdr search)) + then (bss-int :all str) + elseif (null (cddr search)) + then (bss-int (cadr search) str) + else (and-ify (cdr search) str))) + (or (if* (null (cdr search)) + then (bss-int :all str) + elseif (null (cddr search)) + then (bss-int (cadr search) str) + else (or-ify (cdr search) str))) + (not (if* (not (eql (length search) 2)) + then (po-error :syntax-error + :format-control "not takes one argument: ~s" + :format-arguments (list search))) + (format str "not (" ) + (bss-int (cadr search) str) + (format str ")")) + (:seq + (set-ify (list search) str)) + (t (let (arginfo) + (if* (and (symbolp (car search)) + (setq arginfo (get (car search) + 'imap-search-args))) + then + (format str "~a" (string-upcase + (string (car search)))) + (if* (not (equal (length (cdr search)) + (length arginfo))) + then (po-error :syntax-error + :format-control "wrong number of arguments to ~s" + :format-arguments search)) + + (arg-process str (cdr search) arginfo) + + elseif (integerp (car search)) + then (set-ify search str) + else (po-error :syntax-error + :format-control "Illegal form ~s in search string" + :format-arguments (list search)))))) + elseif (integerp search) + then ; a message number + (format str "~s" search) + else (po-error :syntax-error + :format-control "Illegal form ~s in search string" + :format-arguments (list search))))) + + + + + +(defun parse-mail-header (text) + ;; given the partial text of a mail message that includes + ;; at least the header part, return an assoc list of + ;; (header . content) items + ;; Note that the header is string with most likely mixed case names + ;; as it's conventional to capitalize header names. + (let ((next 0) + (end (length text)) + header + value + kind + headers) + (labels ((next-header-line () + ;; find the next header line return + ;; :eof - no more + ;; :start - beginning of header value, header and + ;; value set + ;; :continue - continuation of previous header line + + + (let ((state 1) + beginv ; charpos beginning value + beginh ; charpos beginning header + ch + ) + (tagbody again + + (return-from next-header-line + + (loop ; for each character + + (if* (>= next end) + then (return :eof)) + + (setq ch (char text next)) + (if* (eq ch #\return) + thenret ; ignore return, (handle following linefeed) + else (case state + (1 ; no characters seen + (if* (eq ch #\linefeed) + then (incf next) + (return :eof) + elseif (member ch + '(#\space + #\tab)) + then ; continuation + (setq state 2) + else (setq beginh next) + (setq state 3) + )) + (2 ; looking for first non blank in value + (if* (eq ch #\linefeed) + then ; empty continuation line, ignore + (incf next) + (go again) + elseif (not (member ch + (member ch + '(#\space + #\tab)))) + then ; begin value part + (setq beginv next) + (setq state 4))) + (3 ; reading the header + (if* (eq ch #\linefeed) + then ; bogus header line, ignore + (go again) + elseif (eq ch #\:) + then (setq header + (subseq text beginh next)) + (setq state 2))) + (4 ; looking for the end of the value + (if* (eq ch #\linefeed) + then (setq value + (subseq text beginv + (if* (eq #\return + (char text + (1- next))) + then (1- next) + else next))) + (incf next) + (return (if* header + then :start + else :continue)))))) + (incf next))))))) + + + + (loop ; for each header line + (setq header nil) + (if* (eq :eof (setq kind (next-header-line))) + then (return)) + (case kind + (:start (push (cons header value) headers)) + (:continue + (if* headers + then ; append to previous one + (setf (cdr (car headers)) + (concatenate 'string (cdr (car headers)) + " " + value))))))) + (values headers + (subseq text next end)))) + + +(defun make-envelope-from-text (text) + ;; given at least the headers part of a message return + ;; an envelope structure containing the contents + ;; This is useful for parsing the headers of things returned by + ;; a pop server + ;; + (let ((headers (parse-mail-header text))) + + (make-envelope + :date (cdr (assoc "date" headers :test #'equalp)) + :subject (cdr (assoc "subject" headers :test #'equalp)) + :from (cdr (assoc "from" headers :test #'equalp)) + :sender (cdr (assoc "sender" headers :test #'equalp)) + :reply-to (cdr (assoc "reply-to" headers :test #'equalp)) + :to (cdr (assoc "to" headers :test #'equalp)) + :cc (cdr (assoc "cc" headers :test #'equalp)) + :bcc (cdr (assoc "bcc" headers :test #'equalp)) + :in-reply-to (cdr (assoc "in-reply-to" headers :test #'equalp)) + :message-id (cdr (assoc "message-id" headers :test #'equalp)) + ))) + + + + + + + + + + +(defmethod get-and-parse-from-imap-server ((mb imap-mailbox)) + ;; read the next line and parse it + ;; + ;; + (multiple-value-bind (line count) + (get-line-from-server mb) + (if* *debug-imap* + then (format t "from server: ") + (dotimes (i count)(write-char (schar line i))) + (terpri) + (force-output)) + + (parse-imap-response line count) + )) + + + +(defmethod get-and-parse-from-pop-server ((mb pop-mailbox)) + ;; read the next line from the pop server + ;; + ;; return 3 values: + ;; :ok or :error + ;; a list of rest of the tokens on the line + ;; the whole line after the +ok or -err + + (multiple-value-bind (line count) + (get-line-from-server mb) + + (if* *debug-imap* + then (format t "from server: " count) + (dotimes (i count)(write-char (schar line i))) + (terpri)) + + (parse-pop-response line count))) + + + +;; Parse and return the data from each line +;; values returned +;; tag -- either a string or the symbol :untagged +;; command -- a keyword symbol naming the command, like :ok +;; count -- a number which preceeded the command, or nil if +;; there wasn't a command +;; bracketted - a list of objects found in []'s after the command +;; or in ()'s after the command or sometimes just +;; out in the open after the command (like the search) +;; comment -- the whole of the part after the command +;; +(defun parse-imap-response (line end) + (let (kind value next + tag count command extra-data + comment) + + ;; get tag + (multiple-value-setq (kind value next) + (get-next-token line 0 end)) + + (case kind + (:string (setq tag (if* (equal value "*") + then :untagged + else value))) + (t (po-error :unexpected + :format-control "Illegal tag on response: ~s" + :format-arguments (list (subseq line 0 count)) + :server-string (subseq line 0 end) + ))) + + ;; get command + (multiple-value-setq (kind value next) + (get-next-token line next end)) + + (tagbody again + (case kind + (:number (setq count value) + (multiple-value-setq (kind value next) + (get-next-token line next end)) + (go again)) + (:string (setq command (kwd-intern value))) + (t (po-error :unexpected + :format-control "Illegal command on response: ~s" + :format-arguments (list (subseq line 0 count)) + :server-string (subseq line 0 end))))) + + (setq comment (subseq line next end)) + + ;; now the part after the command... this gets tricky + (loop + (multiple-value-setq (kind value next) + (get-next-token line next end)) + + (case kind + ((:lbracket :lparen) + (multiple-value-setq (kind value next) + (get-next-sexpr line (1- next) end)) + (case kind + (:sexpr (push value extra-data)) + (t (po-error :syntax-error :format-control "bad sexpr form")))) + (:eof (return nil)) + ((:number :string :nil) (push value extra-data)) + (t ; should never happen + (return))) + + (if* (not (member command '(:list :search) :test #'eq)) + then ; only one item returned + (setq extra-data (car extra-data)) + (return))) + + (if* (member command '(:list :search) :test #'eq) + then (setq extra-data (nreverse extra-data))) + + + (values tag command count extra-data comment))) + + + +(defun get-next-sexpr (line start end) + ;; read a whole s-expression + ;; return 3 values + ;; kind -- :sexpr or :rparen or :rbracket + ;; value - the sexpr value + ;; next - next charpos to scan + ;; + (let ( kind value next) + (multiple-value-setq (kind value next) (get-next-token line start end)) + + (case kind + ((:string :number :nil) + (values :sexpr value next)) + (:eof (po-error :syntax-error + :format-control "eof inside sexpr")) + ((:lbracket :lparen) + (let (res) + (loop + (multiple-value-setq (kind value next) + (get-next-sexpr line next end)) + (case kind + (:sexpr (push value res)) + ((:rparen :rbracket) + (return (values :sexpr (nreverse res) next))) + (t (po-error :syntax-error + :format-control "bad sexpression")))))) + ((:rbracket :rparen) + (values kind nil next)) + (t (po-error :syntax-error + :format-control "bad sexpression"))))) + + +(defun parse-pop-response (line end) + ;; return 3 values: + ;; :ok or :error + ;; a list of rest of the tokens on the line, the tokens + ;; being either strings or integers + ;; the whole line after the +ok or -err + ;; + (let (res lineres result) + (multiple-value-bind (kind value next) + (get-next-token line 0 end) + + (case kind + (:string (setq result (if* (equal "+OK" value) + then :ok + else :error))) + (t (po-error :unexpected + :format-control "bad response from server" + :server-string (subseq line 0 end)))) + + (setq lineres (subseq line next end)) + + (loop + (multiple-value-setq (kind value next) + (get-next-token line next end)) + + (case kind + (:eof (return)) + ((:string :number) (push value res)))) + + (values result (nreverse res) lineres)))) + + + + + + + + + + +(defparameter *char-to-kind* + (let ((arr (make-array 256 :initial-element nil))) + + (do ((i #.(char-code #\0) (1+ i))) + ((> i #.(char-code #\9))) + (setf (aref arr i) :number)) + + (setf (aref arr #.(char-code #\space)) :space) + (setf (aref arr #.(char-code #\tab)) :space) + (setf (aref arr #.(char-code #\return)) :space) + (setf (aref arr #.(char-code #\linefeed)) :space) + + (setf (aref arr #.(char-code #\[)) :lbracket) + (setf (aref arr #.(char-code #\])) :rbracket) + (setf (aref arr #.(char-code #\()) :lparen) + (setf (aref arr #.(char-code #\))) :rparen) + (setf (aref arr #.(char-code #\")) :dquote) + + (setf (aref arr #.(char-code #\^b)) :big-string) ; our own invention + + arr)) + + +(defun get-next-token (line start end) + ;; scan past whitespace for the next token + ;; return three values: + ;; kind: :string , :number, :eof, :lbracket, :rbracket, + ;; :lparen, :rparen + ;; value: the value, either a string or number or nil + ;; next: the character pos to start scanning for the next token + ;; + (let (ch chkind colstart (count 0) (state :looking) + collector right-bracket-is-normal) + (loop + ; pick up the next character + (if* (>= start end) + then (if* (eq state :looking) + then (return (values :eof nil start)) + else (setq ch #\space)) + else (setq ch (schar line start))) + + (setq chkind (aref *char-to-kind* (char-code ch))) + + (case state + (:looking + (case chkind + (:space nil) + (:number (setq state :number) + (setq colstart start) + (setq count (- (char-code ch) #.(char-code #\0)))) + ((:lbracket :lparen :rbracket :rparen) + (return (values chkind nil (1+ start)))) + (:dquote + (setq collector (make-array 10 + :element-type 'character + :adjustable t + :fill-pointer 0)) + (setq state :qstring)) + (:big-string + (setq colstart (1+ start)) + (setq state :big-string)) + (t (setq colstart start) + (setq state :literal)))) + (:number + (case chkind + ((:space :lbracket :lparen :rbracket :rparen + :dquote) ; end of number + (return (values :number count start))) + (:number ; more number + (setq count (+ (* count 10) + (- (char-code ch) #.(char-code #\0))))) + (t ; turn into an literal + (setq state :literal)))) + (:literal + (case chkind + ((:space :rbracket :lparen :rparen :dquote) ; end of literal + (if* (and (eq chkind :rbracket) + right-bracket-is-normal) + then nil ; don't stop now + else (let ((seq (subseq line colstart start))) + (if* (equal "NIL" seq) + then (return (values :nil + nil + start)) + else (return (values :string + seq + start)))))) + (t (if* (eq chkind :lbracket) + then ; imbedded left bracket so right bracket isn't + ; a break char + (setq right-bracket-is-normal t)) + nil))) + (:qstring + ;; quoted string + ; (format t "start is ~s kind is ~s~%" start chkind) + (case chkind + (:dquote + ;; end of string + (return (values :string collector (1+ start)))) + (t (if* (eq ch #\\) + then ; escaping the next character + (incf start) + (if* (>= start end) + then (po-error :unexpected + :format-control "eof in string returned")) + (setq ch (schar line start))) + (vector-push-extend ch collector) + + (if* (>= start end) + then ; we overran the end of the input + (po-error :unexpected + :format-control "eof in string returned"))))) + (:big-string + ;; super string... just a block of data + ; (format t "start is ~s kind is ~s~%" start chkind) + (case chkind + (:big-string + ;; end of string + (return (values :string + (subseq line colstart start) + (1+ start)))) + (t nil))) + + + ) + + (incf start)))) + + + +; this used to be exported from the excl package +#+(version>= 6 0) +(defvar *keyword-package* (find-package :keyword)) + + +(defun kwd-intern (string) + ;; convert the string to the current preferred case + ;; and then intern + (intern (case excl::*current-case-mode* + ((:case-sensitive-lower + :case-insensitive-lower) (string-downcase string)) + (t (string-upcase string))) + *keyword-package*)) + + + + + + + + + + + + + + +;; low level i/o to server + +(defun get-line-from-server (mailbox) + ;; Return two values: a buffer and a character count. + ;; The character count includes up to but excluding the cr lf that + ;; was read from the socket. + ;; + (let* ((buff (get-line-buffer 0)) + (len (length buff)) + (i 0) + (p (post-office-socket mailbox)) + (ch nil) + (whole-count) + ) + + (handler-case + (flet ((grow-buffer (size) + (let ((newbuff (get-line-buffer size))) + (dotimes (j i) + (setf (schar newbuff j) (schar buff j))) + (free-line-buffer buff) + (setq buff newbuff) + (setq len (length buff))))) + + ;; increase the buffer to at least size + ;; this is somewhat complex to ensure that we aren't doing + ;; buffer allocation within the with-timeout form, since + ;; that could trigger a gc which could then cause the + ;; with-timeout form to expire. + (loop + + (if* whole-count + then ; we should now read in this may bytes and + ; append it to this buffer + (multiple-value-bind (ans this-count) + (get-block-of-data-from-server mailbox whole-count) + ; now put this data in the current buffer + (if* (> (+ i whole-count 5) len) + then ; grow the initial buffer + (grow-buffer (+ i whole-count 100))) + + (dotimes (ind this-count) + (setf (schar buff i) (schar ans ind)) + (incf i)) + (setf (schar buff i) #\^b) ; end of inset string + (incf i) + (free-line-buffer ans) + (setq whole-count nil) + ) + elseif ch + then ; we're growing the buffer holding the line data + (grow-buffer (+ len 200)) + (setf (schar buff i) ch) + (incf i)) + + + (block timeout + (mp:with-timeout ((timeout mailbox) + (po-error :timeout + :format-control "imap server failed to respond")) + ;; read up to lf (lf most likely preceeded by cr) + (loop + (setq ch (read-char p)) + (if* (eq #\linefeed ch) + then ; end of line. Don't save the return + (if* (and (> i 0) + (eq (schar buff (1- i)) #\return)) + then ; remove #\return, replace with newline + (decf i) + (setf (schar buff i) #\newline) + ) + ;; must check for an extended return value which + ;; is indicated by a {nnn} at the end of the line + (block count-check + (let ((ind (1- i))) + (if* (and (>= i 0) (eq (schar buff ind) #\})) + then (let ((count 0) + (mult 1)) + (loop + (decf ind) + (if* (< ind 0) + then ; no of the form {nnn} + (return-from count-check)) + (setf ch (schar buff ind)) + (if* (eq ch #\{) + then ; must now read that many bytes + (setf (schar buff ind) #\^b) + (setq whole-count count) + (setq i (1+ ind)) + (return-from timeout) + elseif (<= #.(char-code #\0) + (char-code ch) + #.(char-code #\9)) + then ; is a digit + (setq count + (+ count + (* mult + (- (char-code ch) + #.(char-code #\0))))) + (setq mult (* 10 mult)) + else ; invalid form, get out + (return-from count-check))))))) + + + (return-from get-line-from-server + (values buff i)) + else ; save character + (if* (>= i len) + then ; need bigger buffer + (return)) + (setf (schar buff i) ch) + (incf i))))))) + (error (con) + ;; most likely error is that the server went away + (ignore-errors (close p)) + (po-error :server-shutdown-connection + :format-control "condition signalled: ~a~%most likely server shut down the connection." + :format-arguments (list con))) + ))) + + +(defun get-block-of-data-from-server (mb count &key save-returns) + ;; read count bytes from the server returning it in a line buffer object + ;; return as a second value the number of characters saved + ;; (we drop #\return's so that lines are sepisarated by a #\newline + ;; like lisp likes). + ;; + (let ((buff (get-line-buffer count)) + (p (post-office-socket mb)) + (ind 0)) + (mp:with-timeout ((timeout mb) + (po-error :timeout + :format-control "imap server timed out")) + + (dotimes (i count) + (if* (eq #\return (setf (schar buff ind) (read-char p))) + then (if* save-returns then (incf ind)) ; drop #\returns + else (incf ind))) + + + (values buff ind)))) + + +;;-- reusable line buffers + +(defvar *line-buffers* nil) + +(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 + (dolist (buff *line-buffers* (make-string size)) + (if* (>= (length buff) size) + then ; use this one + (setq *line-buffers* (delete buff *line-buffers*)) + (return buff))))) + + +(defun free-line-buffer (buff) + (mp:without-scheduling + (push buff *line-buffers*))) + +(defun init-line-buffer (new old) + ;; copy old into new + (declare (optimize (speed 3))) + (dotimes (i (length old)) + (declare (fixnum i)) + (setf (schar new i) (schar old i)))) + + + + + ;;;;;;; + +; date functions + +(defun universal-time-to-rfc822-date (ut) + ;; convert a lisp universal time to rfc 822 date + ;; + (multiple-value-bind + (sec min hour date month year day-of-week dsp time-zone) + (decode-universal-time ut 0) + (declare (ignore time-zone sec min hour day-of-week dsp time-zone)) + (format nil "~d-~a-~d" + date + (svref + '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + month + ) + year))) + + + + diff --git a/postoffice.html b/postoffice.html new file mode 100644 index 0000000..9dfd1a6 --- /dev/null +++ b/postoffice.html @@ -0,0 +1,1214 @@ + + + +Allegro CL imap and pop interface + + + + + +

Allegro CL imap and pop interface

+ +

copyright (c) 1999 Franz Inc.

+ +

 

+ +

imap is a client-server protocol for processing +electronic mail boxes.  imap is the successor to the pop +protocol.   It is not an upward compatible successor. +     The main focus of this document is the imap +protocol.    Only one small section describes the functions in the pop +interface.

+ +

The contents of this document are:

+ + + +

The imap interface is based on the Imap4rev1 protocol described in +rfc2060.   Where this document is describing the actions of the imap commands it +should be considered a secondary source of information about those commands and rfc2060 +should be considered the primary source.

+ +

The advantages of imap over pop are:

+ +
    +

  1. imap can work with multiple mailboxes (pop works + with a single mailbox)

    +
    2. +

  2. With imap you're encouraged to leave mail in mailboxes + on the server machine, thus it can be read from any machine on the network.    + With pop you're encouraged to download the mail to the client machine's + disk, and it thus becomes inaccessible to all other client machines.

    +
    3. +

  3. imap parses the headers of messages thus allowing + easier analysis of mail messages by the client program.

    +
    4. +

  4. imap supports searching messages for data and sorting + by date.

    +
    5. +

  5. imap supports annotating messages with flags, thus + making subsequent searching easier.

    +
    6. +
+ +

 

+ +

Package

+ +

The functions in this interface are defined in the net.post-office +package.   The previous version of this module gave this package the po +nickname.  We've removed that nickname to reduce the possibility of clashing with +user-defined packages.  You are free to add that nickname back if you so desire.

+ +

 

+ +

Mailboxes

+ +

Mailboxes are repositories for messages.   Mailboxes are named +by Lisp strings.  The mailbox "inbox" always exists and it is the mailbox +in which new messages are stored.   New mailboxes can be created. +    They can have simple names, like "foo" or they can have +hierarchical names (like "clients/california/widgetco").   After +connecting to an imap server you can determine what string of characters you must use +between simple names to create a hierarchical name (in this example "/" was the +separator character).

+ +

Each mailbox has an associated unique number called its uidvalidity. +    This number won't change as long as imap is the only +program used to manipulate the mailbox.   In fact if you see that the number has +changed then that means that some other program has done something to the mailbox that +destroyed the information that imap had been keeping about the +mailbox.    In particular you can't now retrieve messages by their unique +ids that you had used before.

+ +

Messages

+ +

Messages in a mailbox can be denoted in one of two ways:  message +sequence number or  unique id.  

+ +

The message sequence number is the normal way.  The messages +in a mailbox are numbered from 1 to N where N is the number of messages in the mailbox. +   There are never any gaps in the sequence numbers.  If you tell imap +to delete messages 3,4 and 5 then it will return a value telling you the it has deleted +messages 3,3 and 3.  This is because when you deleted message 3, message 4 became the +new message 3 just before it was deleted and then message 5 became message 3 just before +it was deleted.

+ +

A unique id of a message is a number associated with a message +that is unique only within a mailbox.   As long as the uidvalidity value of a +mailbox doesn't change, the unique ids used in deleted messages will never be reused for +new messages. 

+ +

Flags

+ +

A flag is a symbol denoting that a message or mailbox has a certain +property.   We use keywords in Lisp to denote flags.   There are two +kinds of flags - System and User flags.  System flags begin with the backslash +character, which is an unfortunate design decision  since that means that in Lisp we +have to remember to use two backslashes (e.g.  :\\deleted). +   A subset of the flags can be stored permanently in the mailbox with the +messages.  When a connection is made to an imap server it will +return the list of flags and permanent flags (and these are stored in the mailbox object +returned for access by the program).   If the list of permanent flags includes :\\* +then the program can create its own flag names (not beginning with a backslash) and can +store them permanently in messages.

+ +

Some of the important system flags are:

+ +
    +

  • :\\seen - this means that the message has been read +   (a fetch-letter has been done that includes the content of the + message, not just its headers)

    +
    • +

  • :\\deleted - the message will be deleted the next time + an expunge-mailbox or close-mailbox is done.

    +
    • +

  • :\\recent - this is the first session to have been + notified about this message being present in the mailbox.

    +
    • +
+ +

 

+ +

Connecting to the server

+ +

 

+ +

(make-imap-connection host &key user +password port timeout)

+ +

This creates a connection to the imap server on machine host +and logs in as user with password password.   The +port argument defaults to143, which is the port on which the imap +server normally listens.    The timeout argument defaults +to 30 (seconds) and this value is used to limit the amount of time this imap interface +code will wait for a response from the server before giving up.    In +certain circumstances the server may get so busy that you see timeout errors signaled in +this code.  In that case you should specify a larger timeout when connecting.

+ +

The make-imap-connection function returns a mailbox +object which is then passed to other functions in this interface.   From this +one connection you can access all of the mailboxes owned by user.

+ +

After  the connection is  established a mailbox is not +selected.   In this state attempting to execute message access functions may +result in cryptic error messages from the imap server that won't tell you +what you need to know -- that a mailbox is not selected.   Therefore be sure to +select a mailbox using select-mailbox shortly after connecting.

+ +

 

+ +

 

+ +

(close-connection mailbox)

+ +

This sends a logout command to the imap +server and then closes the socket that's communicating with the imap +server.    mailbox is the object returned by make-imap-connection. +   This does not close the currently select mailbox before logging out, +thus messages marked to be deleted in the currently selected mailbox will not be +removed from the  mailbox.  Use close-mailbox or expunge-mailbox +before calling this close-connection to ensure that messages to be +deleted are deleted.

+ +

 

+ +

 

+ +

Mailbox manipulation

+ +

These functions work on mailboxes as a whole.    The mailbox +argument to the functions is is the object returned by make-imap-connection. +  If a return value isn't specified for a function then the return value +isn't important - if something goes wrong an error will be signaled.

+ +

 

+ +

(select-mailbox mailbox name)

+ +

makes the mailbox named by the string name be the current +mailbox and store statistics about that mailbox in the mailbox object +where they can be retrieved by the accessors described below.     The +selected mailbox is the source for all message manipulation functions.

+ +

 

+ +

(create-mailbox mailbox name)

+ +

creates a new mailbox with the given name.   It +is an error if the mailbox already exists.  If you want to create a mailbox in a +hierarchy then you should be sure that it uses the correct hierarchy separator character +string (see mailbox-separator).   You do not +  have to create intermediate levels of the hierarchy yourself -- just provide the +complete name and the imap server will create all necessary levels.

+ +

 

+ +

(delete-mailbox mailbox name)

+ +

deletes the mailbox with the given name.

+ +

 

+ +

(rename-mailbox mailbox  old-name +new-name)

+ +

changes the name of mailbox old-name to new-name. +  It's an error if new-name already exists.  There's a special +behavior if old-name is "inbox".  In this case all of the +messages in "inbox" are moved to new-name mailbox, but the +"inbox" mailbox continues to exist.   Note: The imap server +supplied with Linux does not support this special behavior of renaming +"inbox".

+ +

 

+ +

(mailbox-list mailbox &key reference +pattern)

+ +

returns a list of items describing the mailboxes that match the arguments. +     The reference is the root of the hierarchy to +scan.  By default is is the empty string (from which all mailboxes are reachable). +    The pattern is a string matched against all mailbox +names reachable from reference. There are two special characters allowed +in the pattern:  Asterisk (*) matches all characters including +hierarchy delimiters.   Percent (%) matches all characters but not the hierarchy +delimiter.  Thus

+ +

(mailbox-list mailbox :pattern "*")

+ +

returns a list of all mailboxes at all depths in the hierarchy. +  

+ +

The value returned is a list of lists, but we've created the mailbox-list +struct definition in order to make accessing the parts of the inner lists   +easier.   The accessors for that structure are:

+ +

 

+ +

(mailbox-list-flags mailbox-list) 

+ +

returns the flags describing this entry.   The most important +flag to check is :\\noselect as this specifies that this is not a mailbox +but instead just a directory in the hierarchy of mailboxes.   The flag :\\noinferiors +specifies that you can't create a hierarchical mailbox name with this as a prefix. +   This flag is often associated with the special mailbox "inbox".

+ +

 

+ +

(mailbox-list-separator mailbox-list)

+ +

returns a string containing the characters used to separate names in a +hierarchical name.

+ +

 

+ +

(mailbox-list-name mailbox-list)

+ +

returns the name of the mailbox or directory (see mailbox-list-flags to +determine which it is).

+ +

 

+ +

Message manipulation

+ +

These functions work with the messages in the currently selected mailbox. +    The mailbox argument is the object returned by make-imap-connection. +  The messages argument is either a number (denoting a single +message), or is the list (:seq N M) denoting messages N +through M, or is a list of numbers and :seq forms +denoting the messages specified in the list.

+ +

 

+ +

(alter-flags mailbox messages &key +flags add-flags remove-flags silent uid)

+ +

changes the flags of the messages in the specified way.  Exactly one of  flags, +add-flags, and remove-flags must  be specified.  flags +specifies the complete set of flags to be stores in the messages and the +other two add or remove flags.   If uid is true then messages +will be interpreted as unique ids rather than message sequence numbers. +     Normally alter-flags returns a data structure +that describes the state of the flags after the alternation has been done.  This data +structure can be examined  with the fetch-field function. +   If silent is true then this data structure won't be created +thus saving some time and space.

+ +

Removing a message from a mailbox is done by adding the :\\deleted +flag to the message and then either calling close-mailbox or expunge-mailbox.

+ +

 

+ +

(close-mailbox mailbox)

+ +

permanently removes all messages flagged as :\\deleted from the +currently selected mailbox and then un-selects the currently selected mailbox.  After +this command has finished there is no currently selected mailbox.

+ +

 

+ +

(copy-to-mailbox mailbox messages +destination &key uid)

+ +

copies the specified messages from the currently selected +mailbox to the mailbox named destination (given as a string).   The +flags are copied as well. The destination mailbox must already exist.  The messages +are not removed from the selected mailbox after the copy   .If uid +is true then the messages are considered to be unique ids rather than +message sequence numbers.

+ +

 

+ +

(delete-letter mailbox messages &key +expunge uid)

+ +

Mark the messages for deletion and then remove them +permanently (using expunge-mailbox) if expunge is true. +   expunge defaults to true.    If uid +is true then the message numbers are unique ids instead of messages sequence numbers.

+ +

 

+ +

(expunge-mailbox mailbox)

+ +

permanently removes all messages flagged as :\\deleted +from the currently selected mailbox.   The currently selected mailbox stays +selected.

+ +

 

+ +

(fetch-field message part info &key +uid)

+ +

is used to extract the desired information from the value returned by fetch-letter. +    With fetch-letter you can retrieve a variety of +information about one or more messages and fetch-field can search though +that information and return a  particular piece of information about a particular +letter.   message is the message number (it's assumed to be a +message sequence number unless uid is true, in which case it's a unique +id).   part is the type of information desired.  It is a +string just as used in the call to fetch-letter.

+ +

 

+ +

(fetch-letter mailbox message &key +uid)

+ +

Return the complete message, headers and body, as one big string.   +This is a combination of fetch-field and fetch-parts +where the part specification is "body[]".

+ +

 

+ +

(fetch-parts mailbox messages parts +&key uid)

+ +

retrieves the specified parts of the specified messages. +   If uid is true then the messages +are considered to be unique ids rather than message sequence numbers. +     The description of what can be specified for parts is +quite complex and is described in the section below "Fetching a Letter".

+ +

The return value from this function is a structure that can be examined +with fetch-field.

+ +

When the result returned includes an envelope value the following +functions can be used to extract  the components of the envelope:

+ +
    +

  • envelope-date

    +
    • +

  • envelope-subject

    +
    • +

  • envelope-from

    +
    • +

  • envelope-sender

    +
    • +

  • envelope-reply-to

    +
    • +

  • envelope-to

    +
    • +

  • envelope-cc

    +
    • +

  • envelope-bcc

    +
    • +

  • envelope-in-reply-to

    +
    • +

  • envelope-message-id

    +
    • +
+ +

 

+ +

 

+ +

(noop mailbox)

+ +

does nothing but  remind the imap server that this +client is still active, thus resetting the timers used in the server that will +automatically shut down this connection after a period of inactivity.   Like all +other commands if messages have been added to the currently selected mailbox, the server +will return the new message count as a response to the noop command, and +this can be check using mailbox-message-count.   

+ +

 

+ +

(search-mailbox mailbox search-expression +&key uid)

+ +

return a list of messages in the mailbox that satisfy the +search-expression.   If uid is true then unique ids +will be returned instead of message sequence numbers.  See the section +"Searching for messages" for details on the search-expression.

+ +

 

+ +

Mailbox Accessors

+ +

The mailbox object contains information about the imap server +it's connected to as well as the currently selected mailbox.   This information +can potentially be updated each time a request is made to the imap server. +   The following functions access values from the mailbox object.

+ +

(mailbox-flags mailbox)

+ +

returns a complete list of flags used in all the messages in this mailbox.

+ +

 

+ +

(mailbox-permanent-flags mailbox)

+ +

returns a list of flags that can be stored permanently in a message. +  If the flag :\\* is present then it means that the client can +create its own flags.

+ +

 

+ +

(mailbox-message-count mailbox)

+ +

returns the number of messages in the currently selected mailbox

+ +

 

+ +

(mailbox-recent-messages mailbox)

+ +

returns the number of messages have just arrived in the mailbox.

+ +

 

+ +

(mailbox-separator mailbox)

+ +

returns the hierarchy separator string for this imap server.

+ +

 

+ +

(mailbox-uidnext mailbox)

+ +

returns the value predicated to be the  unique id assigned to the +next message.

+ +

 

+ +

(mailbox-uidvalidty mailbox)

+ +

returns the uidvalidity value for the currently selected mailbox.

+ +

 

+ +

 

+ +

Fetching a Letter

+ +

When using fetch-parts to access letters, you must +specify the parts of the messages in which you're interested.   There are a wide +variety of specifiers, some redundant and overlapping, described in the imap specification +in rfe2060.  We'll describe the most common ones here.   The specification +is always a string but it may be specified more than one thing by the use of parentheses +in the string, e.g. "(flags envelope)".  

+ +

The most common specifiers are:

+ +
    +

  • body[] - this returns the full message: headers and + body.   You can use fetch-letter if you only want this part and + you want to avoid having to call fetch-field.

    +
    • +

  • body[text] - this returns just the the text of the body + of the message, not the header.

    +
    • +

  • body - this returns a list describing the structure of + the message.

    +
    • +

  • envelope - this parses the header and returns a list of + information in it.   We've defined a set of accessors (like + envelope-xxx) that allow you to retrieve the envelope information easily.

    +
    • +

  • flags - return a list of the flags in the message

    +
    • +

  • uid - the unique identifier of the message

    +
    • +
+ +

 

+ +

The result of a fetch-parts is a data structure +containing all of the requested information.   The fetch-field +function is then used to extract the particular information for the particular message.

+ +

 

+ +

Searching for Messages

+ +

.The imap server is able to search for messages matching +a search expression.     A search-expression is a predicate or one of +these forms:

+ +
    +

  • (and search-expression ...)

    +
    • +

  • (or  search-expression ...)

    +
    • +

  • (not search-expression)

    +
    • +
+ +

A predicate is

+ +
    +

  • a number in which case the predicate is true if and only if we're are + considering this message

    +
    • +

  • a (:seq N M) expression that is true if we're + considering messages N through M.

    +
    • +

  • :all - this predicate is always true

    +
    • +

  • :answered - true if the message has the :\\answered + flag

    +
    • +

  • (:bcc "string") - true if the envelope + structure's bcc field contains this "string".

    +
    • +

  • (:before date) - true if the messages internal date is + before this date.  The date can either be a string in the rfc822 form (e.g. + "7-Mar-1999") or a lisp universal time.

    +
    • +

  • (:body "string") - true if the body of the + message contains "string"

    +
    • +

  • (:cc "string") -  true if the envelope + structure's cc field contains this "string".

    +
    • +

  • :deleted - true if the :\\deleted flag + is set for this message

    +
    • +

  • :draft - true if the :\\draft flag is + set for this message

    +
    • +

  • :flagged - true if the :\\flagged flag + is set for this message

    +
    • +

  • (:from "string") -  true if the envelope + structure's from  field contains this "string".

    +
    • +

  • (:header "field" "string") - true + if the message contains a header named "field" and its value contains + "string".

    +
    • +

  • (:keyword flag) - true if the specified flag is set for + this message

    +
    • +

  • (:larger N) - true if the rfc822 size of the message is + larger than N.

    +
    • +

  • :new - true if the message has the :\\recent + flag set but not the :\\seen flag.

    +
    • +

  • :seen - true if the message has the :\\seen flag + set.

    +
    • +

  • (:sentbefore date) - true if the message's Date header + is earlier than the given date.  See the description of :before for the format of + dates.

    +
    • +

  • (:senton date) - true if the message's Date header is + within the specified date.

    +
    • +

  • (:sentsince date) - true if the message's Date header + is within or since the given date.

    +
    • +

  • (:smaller N) - true if the rfc822 size of the message + is smaller than N

    +
    • +

  • (:subject "string") - true if the Subject + header line of the message contains "string"

    +
    • +

  • (:text "string") - true if the message's + header or body contains the specified "string"

    +
    • +

  • (:to "string") - true if the envelope + structure's to field contains this "string".

    +
    • +

  • (:uid message-set) - true if the message is one of the + message denoted by the message set, where the message set describes messages by unique id.

    +
    • +

  • :unanswered - true if the message does not have the :\\answered + flag set

    +
    • +

  • :undeleted - true if the message does not have the :\\deleted + flag set

    +
    • +

  • :undraft - true if the message does not have the :\\draft + flag set.

    +
    • +

  • :unflagged - true if the message does not have the :\\flagged + flag set.

    +
    • +

  • (:unkeyword flag) - true if the message does not have + the specified flag set.

    +
    • +

  • :unseen - true if the message does not have the :\\seen + flag set.

    +
    • +
+ +

 

+ +

Examples

+ +

We show an example of using this interface

+ +

 

+ +

Connect to the imap server on the machine holding the email:

+
+ +
user(2): (setq mb (make-imap-connection "mailmachine.franz.com" 
+
+                            :user "myacct" 
+
+                            :password "mypasswd"))
+
+#<mailbox::imap-mailbox @ #x2064ca4a>
+
+ +

 

+ +

Select the inbox, that's where the incoming mail arrives:

+
+ +
+
+user(3): (select-mailbox mb "inbox")
+
+t
+
+ +

 

+ +

Check how many messages are in the mailbox:

+
+ +
+
+user(4): (mailbox-message-count mb)
+
+7
+
+ +

There are seven messages at the moment.   Fetch the +whole 4th message.  We could call (fetch-letter mb 4) here instead and then not have +to call fetch-field later.

+
+ +
+
+user(5): (setq body (fetch-parts mb 4 "body[]"))
+
+((4
+
+("BODY[]" "Return-Path: <jkfmail@tiger.franz.com>
+
+Received: from tiger.franz.com (jkf@tiger [192.132.95.103])
+
+    by tiger.franz.com (8.8.7/8.8.7) with SMTP id LAA20261
+
+    for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 11:36:26 -0700
+
+Date: Mon, 13 Sep 1999 11:36:26 -0700
+
+From: jkf mail tester <jkfmail@tiger.franz.com>
+
+Message-Id: <199909131836.LAA20261@tiger.franz.com>
+
+
+
+message number 5
+
+")))
+
+ +

The value was returned inside a data structure designed to hold +information about one or more messages.   In order to extract the particular +information we want we use fetch-field:

+
+ +
+
+user(6): (fetch-field 4 "body[]" body)
+
+"Return-Path: <jkfmail@tiger.franz.com>
+
+Received: from tiger.franz.com (jkf@tiger [192.132.95.103])
+
+    by tiger.franz.com (8.8.7/8.8.7) with SMTP id LAA20261
+
+    for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 11:36:26 -0700
+
+Date: Mon, 13 Sep 1999 11:36:26 -0700
+
+From: jkf mail tester <jkfmail@tiger.franz.com>
+
+Message-Id: <199909131836.LAA20261@tiger.franz.com>
+
+
+
+message number 5
+
+"
+
+ +

We use the search function to find all the messages containing the +word blitzfig.  It turns out there is only one.  We then extract the contents of +that message.

+
+ +
+
+user(7): (search-mailbox mb '(:text "blitzfig"))
+
+(7)
+
+user(8): (fetch-field 7 "body[]" (fetch-letter mb 7 "body[]"))
+
+"Return-Path: <jkf@verada.com>
+
+Received: from main.verada.com (main.verada.com [208.164.216.3])
+
+    by tiger.franz.com (8.8.7/8.8.7) with ESMTP id NAA20541
+
+    for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 13:37:24 -0700
+
+Received: from main.verada.com (IDENT:jkf@localhost [127.0.0.1])
+
+    by main.verada.com (8.9.3/8.9.3) with ESMTP id NAA06121
+
+    for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 13:36:54 -0700
+
+Message-Id: <199909132036.NAA06121@main.verada.com>
+
+To: jkfmail@tiger.franz.com
+
+Subject: s test
+
+Date: Mon, 13 Sep 1999 13:36:54 -0700
+
+From: jkf <jkf@verada.com>
+
+
+
+secret word: blitzfig
+
+ok?
+
+"
+
+ +

We've been using message sequence numbers up to now.    +The are the simplest to use but if you're concerned with keeping track of messages when +deletions are being done then using unique id's is useful.   Here we do the +above search example using uids:

+
+ +
+
+user(9): (search-mailbox mb '(:text "blitzfig") :uid t)
+
+(68)
+
+user(10): (fetch-field 68 "body[]" (fetch-letter mb 68 "body[]" :uid t) :uid t)
+
+"Return-Path: <jkf@verada.com>
+
+Received: from main.verada.com (main.verada.com [208.164.216.3])
+
+    by tiger.franz.com (8.8.7/8.8.7) with ESMTP id NAA20541
+
+    for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 13:37:24 -0700
+
+Received: from main.verada.com (IDENT:jkf@localhost [127.0.0.1])
+
+    by main.verada.com (8.9.3/8.9.3) with ESMTP id NAA06121
+
+    for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 13:36:54 -0700
+
+Message-Id: <199909132036.NAA06121@main.verada.com>
+
+To: jkfmail@tiger.franz.com
+
+Subject: s test
+
+Date: Mon, 13 Sep 1999 13:36:54 -0700
+
+From: jkf <jkf@verada.com>
+
+
+
+secret word: blitzfig
+
+ok?
+
+"
+
+ +

We'll delete that letter with the secret word and then note that +we have only six messages in the mailbox.

+
+ +
+
+user(11): (delete-letter mb 68 :uid t)
+
+(7)
+
+user(12): (mailbox-message-count mb)
+
+6
+
+ +

Now we assume that a bit of time has passed and we want to see if +any new messages have been delivered into the mailbox.   In order to find out we +have to send a command to the imap server since it will only notify us of new messages +when it responds to a command.   Since we have nothing to ask the imap server to +do we issue the noop command, which does nothing on the server.

+
+ +
+
+user(13): (noop mb)
+
+nil
+
+user(14): (mailbox-message-count mb)
+
+7
+
+ +

The server told us that there are now 7 messages in the inbox, one +more than before.  Next we create a new mailbox, copy the messages from the inbox to +the new mailbox and then delete them from the inbox.  Note how we use the :seq form +to specify a sequence of messages.

+
+ +
+
+user(15): (create-mailbox mb "tempbox")
+
+t
+
+user(18): (let ((count (mailbox-message-count mb)))
+
+(copy-to-mailbox mb `(:seq 1 ,count) "tempbox")
+
+(delete-letter mb `(:seq 1 ,count)))
+
+(1 1 1 1 1 1 1)
+
+user(19): (mailbox-message-count mb)
+
+0
+
+ +

When we're done there are 0 messages in the currently selected +mailbox, which is inbox.  We now select the maibox we just created and see that the +messages are there.

+
+ +
+
+user(22): (select-mailbox mb "tempbox")
+
+t
+
+user(23): (mailbox-message-count mb)
+
+7
+
+ +

Finally we shut down the connection.   Note that imap +servers will automatically shut down a connection that's been idle for too long (usually +around 10 minutes).  When that happens, the next time the client tries to use an imap +function to access the mailbox an error will occur.   There is nothing that can +be done to revive the connection however it is important to call close-imap-connection on +the lisp side in order to free up the resources still in use for the now dead connection.

+
+ +
+
+user(24): (close-connection mb)
+
+t
+
+
+
+ +

 

+ +

The Pop interface

+ +

The pop protocol is a very simple means for retrieving messages from a +single mailbox.     The functions in the interface are:

+ +

 

+ +

(make-pop-connection host &key user +password port timeout)

+ +

This creates a connection to the pop server on machine host +and logs in as user with password password.   The +port argument defaults to 110, which is the port on which the pop +server normally listens.    The timeout argument defaults +to 30 (seconds) and this value is used to limit the amount of time this pop interface code +will wait for a response from the server before giving up.    In certain +circumstances the server may get so busy that you see timeout errors signaled in this +code.  In that case you should specify a larger timeout when connecting.

+ +

The value returned by this function is a mailbox object.  You can +call mailbox-message-count on the mailbox object to +determine how many letters are currently stored in the mailbox.

+ +

 

+ +

(close-connection mb)

+ +

Disconnect from the pop server.  All messages marked for deletion will be deleted.

+ +

 

+ +

(delete-letter mb messages)

+ +

Mark the specified messages for deletion.  mb is +the mailbox object returned by make-pop-connection.  The messages +are only  marked for deletion.  They are not removed until a close-connection +is done.  If the connection to the pop server is broken before a close-connection +is done, the messages will not be deleted and they will no longer be +marked for deletion either.

+ +

messages can either be a message number, a list of the form (:seq +N M) meaning messages N through M or it can be +a list of message numbers and/or :seq specifiers.   The +messages in a mailbox are numbered starting with one.  Marking a message for deletion +does not affect the numbering of other messages in the mailbox.

+ +

 

+ +

(fetch-letter mb message)

+ +

Fetch from the pop server connection mb the letter numbered message. +   The letters in a mailbox are numbered starting with one.  The entire +message, including the headers,  is returned as a string.    It is an +error to attempt to fetch a letter marked for deletion.

+ +

 

+ +

(make-envelope-from-text text)

+ +

text is a string that is the first part of a mail message, including +at least all of the headers lines and the blank line following the headers.  This +function parses the header lines and return an envelope structure +containing information from the header.   

+ +

 

+ +

(noop mb)

+ +

This is the no-operation command.  It is useful for letting the pop +server know that this connection should be kept alive (pop servers tend +to disconnect after a few minutes of inactivity).   In order to make noop +have behavior similar to that of the imap version of noop, +we don't send a 'noop' command to the pop server, instead we send a 'stat' command. +   This means that after this command is completed the mailbox-message-count +will contain the current count of messages in the mailbox.

+ +

 

+ +

(parse-mail-header text)

+ +

text is a string that is the first part of a mail message, including +at least all of the headers lines and the blank line following the headers.  This +function parses the header lines and returns an assoc list where each item has the form (header +. value).   Both the header and value +are strings.  Note that header names will most likely be mixed case (but this is not +a requirment) so you'll want to use :test #'equalp when searching for a +particular header with assoc.   parse-mail-header +returns as a second value a string that is everything after the headers (which is often +referred to as the body of the message).

+ +

 

+ +

(top-lines mb message line-count)

+ +

Return a string that contains all the header lines and the first line-count +lines of the body of message.   To just retrieve the headers a line-count +of zero can be given.  See the function make-envelope-from-text for +a means of reading the information in the header.

+ +

 

+ +

(unique-id mb &optional message)

+ +

Return the unique indentifier for the given message, or for all non-deleted messages if +message is nil.   The unique identifier is is a string that is +different for every message.   If the message argument  is +not given then this command returns a list of lists where each list contains two items: +the message number and the unique id.

+ +

Conditions

+ +

When an unexpected event occurs a condition is signaled.   This applies to +both the imap and pop interfaces.  There are two +classes of conditions signaled by this package: + +

    +
  • po-condition - this class denotes conditions that need not and in fact + should not interrupt program flow.   When the mailbox server is responding to a + command it sometimes sends informational warning messages and we turn them into + conditions.    It's important for all messages from the server to be read + and processed otherwise the next command issued will see messages in response to the + previous command.   Therefore the user code should never do a non-local-transfer + in response to a po-condition.
    • +
  • po-error - this class denotes conditions that will prevent execution + from continuing.  If one of these errors is not caught, the interactive debugger will + be entered.
    • +
+ +

Instances of both of these condition classes have these slots in addition to the +standard condition slots: 

+ + + + + + + + + + + + + + + + + +
NameAccessorValue
identifierpo-condition-identifierkeyword describing the kind of condition being signaled.  See the + table below for the possible values.
server-stringpo-condition-server-stringIf the condition was created because of a messages sent from the mailbox + server then this is that message.
+ +

The meaning of the identifier value is as follows

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
IdentifierKindMeaning
:problempo-conditionThe server has responded with a warning message.   The most + likely warning is that the mailbox can only be opened in read-only mode due to another + processing using it.
:unknown-okpo-conditionThe server has sent an informative message that we don't understand. +   It's probably safe to ignore this.
:unknown-untaggedpo-conditionThe server has sent an informative message that we don't understand. +   It's probably safe to ignore this.
:error-responsepo-errorThe server cannot execute the requested command.
:syntax-errorpo-errorThe arguments to a function in this package are malformed.
:unexpectedpo-errorThe server has responded a way we don't understand and which prevents us + from continuing
:server-shutdown-connectionpo-errorThe connection to the server has been broken.  This usually occurs + when the connection has been idle for too long and the server intentionally disconnects. +    Just before this condition is signaled we close down the socket connection to + free up the socket resource on our side.  When this condition is signaled the user + program should not use the mailbox object  again (even to call close-connection + on it).
:timeoutpo-errorThe server did not respond quickly enough.   The timeout value + is set in the call to make-imap-connection.
+ +

The smtp interface

+ +

With the smtp interface, a Lisp program can contact a mail server and send electronic +mail.   The contents of the message must be a simple text string.  There is +no provision for encoding binary data and sending it as a Mime attachment.

+ +

 

+ +

(send-letter mail-server from to message &key +subject reply-to)

+ +

mail-server can be a string naming a machine or an integer IP address. +  The mail-server is contacted and asked to send a message +(a string) from a given email address to a given email +address or list of addresses.   The email addresses must be of the form +"foo" or "foo@bar.com".  You can +not use addresses like "Joe +<foo@bar.com>" or "(Joe) +foo@bar.com".  

+ +

A mail header is built and prepended to the message before it is sent. +  The mail header includes a From and To line and +will optionally include a  Subject and Reply-To +line if those are given in the call to send-letter..

+ +

The text of the message should be lines separated by #\newline's. +   The smtp interface will automatically insert the necessary +#\returns's when it transmits the message to the mail server.

+ +

 

+ +

 

+ +

(send-smtp mail-server from to &rest messages)

+ +

mail-server can be a string naming a machine or an integer IP address. +  The mail-server is contacted and asked to send a  message from +a given email address to a given email address or list of addresses. +   The email addresses must be of the form "foo" or "foo@bar.com".  You can not +use addresses like "Joe +<foo@bar.com>" or "(Joe) +foo@bar.com".  

+ +

The message sent is a concatenation of all of the messages (which +should be strings).   A header is not prepended to the message. +  This means that the application program can build its own header if it wants to +include in that header more than send-letter supports (e.g. a Mime +encoded attachment).  If no header is provided then some mail servers (e.g. sendmail) +will notice this fact and will automatically create a header.

+ +

The text of the messages should be lines separated by #\newline's. +   The smtp interface will automatically insert the necessary +#\returns's when it transmits the message to the mail server.

+ +

 

+ +

 

+ +

 

+ +

 

+ + diff --git a/smtp.cl b/smtp.cl new file mode 100644 index 0000000..d6a2217 --- /dev/null +++ b/smtp.cl @@ -0,0 +1,481 @@ +;; -*- 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) diff --git a/smtp.lisp b/smtp.lisp new file mode 100644 index 0000000..31a53c5 --- /dev/null +++ b/smtp.lisp @@ -0,0 +1,489 @@ +;; -*- 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.lisp,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 +;;- + +;;#-allegro (defvar socket:*dns-mode* :clib) + + + +(defpackage :net.post-office + (:use #:lisp #:excl + #+allegro #:socket + #-allegro #:acl-socket) + (: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 (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 (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))) + + ; 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 + (dotted-to-ipaddr name :errorp nil))) + then ipaddr + else ; do mx lookup if acldns is being used +#| + (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))))) +;; ) + + + +(provide :smtp) -- 2.34.1