cl-postoffice-1.8.2.3/ 0000755 0001750 0001750 00000000000 10025721635 014673 5 ustar kevin kevin 0000000 0000000 cl-postoffice-1.8.2.3/package.lisp 0000644 0001750 0001750 00000002661 10025721235 017160 0 ustar kevin kevin 0000000 0000000 (defpackage :net.post-office
(:use #:cl
#-allegro #:acl-compat.excl
#+allegro #:excl
#-allegro :acl-socket
#+allegro :socket
#-allegro :acl-compat-mp
#+allegro :mp)
(:export
;; From smtp.lisp
#:send-letter
#:send-smtp
#:test-email-address
;; From imap.lisp
#:address-name
#:address-additional
#:address-mailbox
#:address-host
#:alter-flags
#:close-connection
#:close-mailbox
#:copy-to-mailbox
#:create-mailbox
#:delete-letter
#:delete-mailbox
#:envelope-date
#:envelope-subject
#:envelope-from
#:envelope-sender
#:envelope-reply-to
#:envelope-to
#:envelope-cc
#:envelope-bcc
#:envelope-in-reply-to
#:envelope-message-id
#:expunge-mailbox
#:fetch-field
#:fetch-letter
#:fetch-parts
#:*imap-version-number*
#:make-envelope-from-text
#:mailbox-flags ; accessor
#:mailbox-permanent-flags ; acc
#:mailbox-list
#:mailbox-list-flags
#:mailbox-list-separator
#:mailbox-list-name
#:mailbox-message-count ; accessor
#:mailbox-recent-messages ; ac
#:mailbox-separator ; accessor
#:mailbox-uidvalidity
#:make-imap-connection
#:make-pop-connection
#:noop
#:parse-mail-header
#:top-lines ; pop only
#:unique-id ; pop only
#:po-condition
#:po-condition-identifier
#:po-condition-server-string
#:po-error
#:rename-mailbox
#:search-mailbox
#:select-mailbox
))
cl-postoffice-1.8.2.3/postoffice.html 0000644 0001750 0001750 00000146503 10016210504 017717 0 ustar kevin kevin 0000000 0000000
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:
imap can work with multiple mailboxes (pop works
with a single mailbox)
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.
imap parses the headers of messages thus allowing
easier analysis of mail messages by the client program.
imap supports searching messages for data and sorting
by date.
imap supports annotating messages with flags, thus
making subsequent searching easier.
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:
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:
| Name |
Accessor |
Value |
| identifier |
po-condition-identifier |
keyword describing the kind of condition being signaled. See the
table below for the possible values. |
| server-string |
po-condition-server-string |
If 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
| Identifier |
Kind |
Meaning |
| :problem |
po-condition |
The 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-ok |
po-condition |
The server has sent an informative message that we don't understand.
It's probably safe to ignore this. |
| :unknown-untagged |
po-condition |
The server has sent an informative message that we don't understand.
It's probably safe to ignore this. |
| :error-response |
po-error |
The server cannot execute the requested command. |
| :syntax-error |
po-error |
The arguments to a function in this package are malformed. |
| :unexpected |
po-error |
The server has responded a way we don't understand and which prevents us
from continuing |
| :server-shutdown-connection |
po-error |
The 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). |
| :timeout |
po-error |
The 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.
cl-postoffice-1.8.2.3/postoffice.asd 0000644 0001750 0001750 00000002735 10016210504 017520 0 ustar kevin kevin 0000000 0000000 ;;;; -*- 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 7061 2003-09-07 06:34:45Z kevin $
;;;;
;;;; 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 #:cl-user)
(defpackage #:postoffice-system (:use #:asdf #:cl))
(in-package #:postoffice-system)
#+(or allegro lispworks cmu openmcl sbcl)
(defsystem postoffice
:name "cl-postoffice"
:author "Franz, Inc"
:version "CVS.2002.10.09"
: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."
:components
((:file "package")
(:file "smtp" :depends-on ("package"))
(:file "imap" :depends-on ("package")))
#-allegro :depends-on #-allegro (:acl-compat)
)
cl-postoffice-1.8.2.3/ChangeLog 0000644 0001750 0001750 00000004613 10016210504 016435 0 ustar kevin kevin 0000000 0000000 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
cl-postoffice-1.8.2.3/smtp.lisp 0000644 0001750 0001750 00000033726 10016210504 016546 0 ustar kevin kevin 0000000 0000000 ;; -*- 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 7061 2003-09-07 06:34:45Z kevin $
;; 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)
(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 #+allegro ipaddr #-allegro server
: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
#+allegro
(if* (or (eq *dns-mode* :acldns)
(member :acldns *dns-mode* :test #'eq))
then (let ((res (dns-query name :type :mx)))
(if* (and res (consp res))
then (cadr res) ; the ip address
else (dns-query name :type :a)))
else ; just do a hostname lookup
(ignore-errors (lookup-hostname name)))
#-allegro
(ignore-errors (lookup-hostname name))
))
)
(provide :smtp)
cl-postoffice-1.8.2.3/imap.lisp 0000644 0001750 0001750 00000150216 10025721622 016513 0 ustar kevin kevin 0000000 0000000 ;; -*- 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.lisp 8753 2004-03-17 01:02:10Z kevin $
;; Description:
;;
;;
;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-
(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)
#+allegro
(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 (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 (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
#+(and allegro (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
#-allegro acl-compat.excl::*current-case-mode*
#+allegro 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
(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))
(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)))
(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)
(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)))