;; -*- mode: common-lisp; package: net.post-office -*-
;;
;; imap.cl
;; imap and pop interface
;;
;; copyright (c) 1999-2002 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 2002-2012 Franz Inc, Oakland, CA - All rights reserved.
;;
;; 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.
;;
;; $Id: imap.cl,v 1.32 2009/03/25 22:46:02 layer Exp $
;; Description:
;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-
(defpackage :net.post-office
(:nicknames #:post-office)
(:use :cl :excl)
(:export
#:address-name
#:address-additional
#:address-mailbox
#:address-host
#:alter-flags
#:close-connection
#:close-mailbox
#:copy-to-mailbox
#:create-mailbox
#:delete-letter
#:delete-mailbox
#:envelope-date
#:envelope-subject
#:envelope-from
#:envelope-sender
#:envelope-reply-to
#:envelope-to
#:envelope-cc
#:envelope-bcc
#:envelope-in-reply-to
#:envelope-message-id
#:expunge-mailbox
#:fetch-field
#:fetch-letter
#:fetch-letter-sequence
#:end-of-letter-p
#:with-fetch-letter-sequence
#: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
#:mailbox-uidnext
#:make-imap-connection
#:make-pop-connection
#:with-imap-connection
#:with-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
#:reset-mailbox
#:search-mailbox
#:select-mailbox
)
)
(in-package :net.post-office)
(provide :imap)
(defparameter *imap-version-number* '(:major 1 :minor 14)) ; 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
;;; state information for fetch-letter-sequence
(fetch-letter-offset
:accessor fetch-letter-offset)
(fetch-letter-number
:accessor fetch-letter-number)
(fetch-letter-uid
:accessor fetch-letter-uid)
(fetch-letter-finished
:accessor fetch-letter-finished)
)
)
(defclass pop-mailbox (post-office)
((message-count ; how many in the mailbox
:accessor mailbox-message-count
:initform 0)
(fetch-letter-state
:accessor state
:initform :invalid)))
(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)
(message
:reader po-condition-message
:initform ""
:initarg :message)
(arguments
:reader po-condition-arguments
:initform nil
:initarg :arguments))
(: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)
(unless (string= (po-condition-message con)
"")
(apply #'format stream
(po-condition-message con)
(po-condition-arguments con)))
(when server-string
(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
:message format-control
: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
:message format-control
: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))
;; returns values: socket starttls
;; server is a cons of the form:
;; (server-name &key (port 25) (ssl nil) (starttls nil) ...ssl-client-keywords...)
(defun connect-to-imap/pop-server (server-info server-type)
(macrolet ((pop-keyword (k l) `(prog1 (getf ,l ,k) (remf ,l ,k)))
(server-port (ssl type) `(cond ((eq ,type :imap) (if ,ssl 993 143))
((eq ,type :pop) (if ,ssl 995 110)))))
(let* ((server (car server-info))
(ssl-args (cdr server-info))
ssl port starttls sock)
(setq ssl (pop-keyword :ssl ssl-args))
(setq port (or (pop-keyword :port ssl-args)
(server-port ssl server-type)))
(setq starttls (pop-keyword :starttls ssl-args))
(setq sock (socket:make-socket :remote-host server
:remote-port port))
(when ssl
(setq sock (apply #'cl+ssl:make-ssl-client-stream
sock
:external-format :iso-8859-1
ssl-args)))
(values sock starttls))) )
(defun make-imap-connection (host &key (port 143)
user
password
(timeout 30))
(multiple-value-bind (sock starttls)
(if (consp host)
(connect-to-imap/pop-server host :imap)
(socket:make-socket :remote-host host :remote-port port))
(let ((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 (ignorable cmd count extra))
(if* (not (eq :untagged tag))
then (po-error :error-response
:server-string comment)))
; check for starttls negotiation
(when starttls
(let (capabilities)
(send-command-get-results
imap "CAPABILITY"
#'(lambda (mb cmd count extra comment)
(declare (ignorable mb cmd count extra))
(setq capabilities comment))
#'(lambda (mb cmd count extra comment)
(check-for-success mb cmd count extra comment
"CAPABILITY")))
(when (and capabilities (match-re "STARTTLS" capabilities :case-fold t
:return nil))
;; negotiate starttls
(send-command-get-results imap "STARTTLS"
#'handle-untagged-response
#'(lambda (mb cmd count extra comment)
(check-for-success mb cmd count extra comment
"STARTTLS")
(setf (post-office-socket mb)
(socket:make-ssl-client-stream
(post-office-socket mb) :method :tlsv1)))))))
; 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))
(multiple-value-bind (sock starttls)
(if (consp host)
(connect-to-imap/pop-server host :pop)
(socket:make-socket :remote-host host :remote-port port))
(let ((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")))
; check for starttls negotiation
(when starttls
(let ((capabilities (send-pop-command-get-results pop "capa" t)))
(when (and capabilities (match-re "STLS" capabilities :case-fold t
:return nil))
(send-pop-command-get-results pop "STLS")
(setf (post-office-socket pop) (socket:make-ssl-client-stream
(post-office-socket pop) :method :tlsv1)))))
; 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))
(when *debug-imap*
(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) (kwd-intern-possible-list 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)
(kwd-intern-possible-list (cadr extra)))
else (po-condition :unknown-ok :server-string comment))))
(t (po-condition :unknown-untagged :server-string comment)))
)
(defmethod begin-extended-results-sequence ((mb pop-mailbox))
(setf (state mb) 1))
(defmethod get-extended-results-sequence ((mb pop-mailbox) buffer &key (start 0) (end (length buffer)))
(declare (optimize (speed 3) (safety 1)))
(let ((inpos start)
(outpos start)
(sock (post-office-socket mb))
ch
stop)
(macrolet ((add-to-buffer ()
`(progn
(setf (schar buffer outpos) ch)
(incf outpos))))
(while (and (< inpos end) (/= (state mb) 4))
(setf stop (read-sequence buffer sock :start inpos :end end :partial-fill t))
(while (< inpos stop)
(setf ch (schar buffer inpos))
(if* (eq ch #\return)
thenret ; ignore crs
else (ecase (state mb)
(1 (if* (eq ch #\.) ; at beginning of line
then (setf (state mb) 2)
elseif (eq ch #\linefeed)
then
(add-to-buffer) ; state stays at 1
else
(setf (state mb) 3)
(add-to-buffer)))
(2 ; seen first dot
(if* (eq ch #\linefeed)
then ; end of results
(setf (state mb) 4)
(return)
else
(setf (state mb) 3)
(add-to-buffer))) ; normal reading
(3 ; middle of line
(if* (eq ch #\linefeed)
then (setf (state mb) 1))
(add-to-buffer))))
(incf inpos))
(setf inpos outpos))
outpos)))
(defmacro end-of-extended-results-p (mb)
`(= (state ,mb) 4))
(defmethod end-extended-results-sequence ((mb pop-mailbox))
(declare (optimize (speed 3) (safety 1)))
(let ((buffer (make-string 4096)))
(until (end-of-extended-results-p mb)
(get-extended-results-sequence mb buffer)))
(setf (state mb) :invalid-state)
t)
(defmacro with-extended-results-sequence ((mailbox) &body body)
(let ((mb (gensym)))
`(let ((,mb ,mailbox))
(begin-extended-results-sequence ,mb)
(unwind-protect
(progn
,@body)
;; cleanup
(end-extended-results-sequence ,mb)))))
(defun send-pop-command-get-results (pop command &optional extrap)
(declare (optimize (speed 3) (safety 1)))
;; 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)))
(buflen (length buf))
(pos 0))
(with-extended-results-sequence (pop)
(until (end-of-extended-results-p pop)
(if* (>= pos buflen)
then ;; grow buffer
(if* (>= buflen (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 (* buflen 2))))
(init-line-buffer new-buf buf)
(free-line-buffer buf)
(setq buf new-buf)
(setq buflen (length buf))))
(setf pos (get-extended-results-sequence pop buf :start pos :end buflen))))
(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 begin-fetch-letter-sequence ((mb imap-mailbox) number &key uid)
(setf (fetch-letter-offset mb) 0)
(setf (fetch-letter-number mb) number)
(setf (fetch-letter-uid mb) uid)
(setf (fetch-letter-finished mb) nil))
(defmethod begin-fetch-letter-sequence ((mb pop-mailbox) number &key uid)
(declare (ignore uid))
(send-pop-command-get-results mb (format nil "RETR ~d" number))
(begin-extended-results-sequence mb))
(defmethod fetch-letter-sequence ((mb imap-mailbox) buffer
&key (start 0) (end (length buffer)))
(let* ((num (fetch-letter-number mb))
(offset (fetch-letter-offset mb))
(uid (fetch-letter-uid mb))
(buflen (- end start))
(data (fetch-field num (format nil "body[]<~d>" offset)
(fetch-parts mb num
(format nil "body[]<~d.~d>" offset buflen)
:uid uid)
:uid uid))
(datalen (length data)))
(setf (subseq buffer start end) data)
(if* (and (> buflen 0) (= datalen 0))
then (setf (fetch-letter-finished mb) t))
(setf (fetch-letter-offset mb) (+ offset buflen))
(+ start datalen)))
(defmethod fetch-letter-sequence ((mb pop-mailbox) buffer &key (start 0) (end (length buffer)))
(get-extended-results-sequence mb buffer :start start :end end))
(defmethod end-fetch-letter-sequence ((mb imap-mailbox))
)
(defmethod end-fetch-letter-sequence ((mb pop-mailbox))
(end-extended-results-sequence mb))
(defmethod end-of-letter-p ((mb imap-mailbox))
(fetch-letter-finished mb))
(defmethod end-of-letter-p ((mb pop-mailbox))
(end-of-extended-results-p mb))
(defmacro with-fetch-letter-sequence ((mailbox &rest args) &body body)
(let ((mb (gensym)))
`(let ((,mb ,mailbox))
(begin-fetch-letter-sequence ,mb ,@args)
(unwind-protect
(progn
,@body)
;; cleanup
(end-fetch-letter-sequence ,mb)))))
(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 ; we can end up with sublists of forms if we
; do add-flags with a list of flags. this seems like
; a bug in the imap server.. but we have to deal with it
(setf (cadr xx) (kwd-intern-possible-list (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))
(defmethod reset-mailbox ((pb pop-mailbox))
;; undo's deletes
(send-pop-command-get-results pb "RSET")
)
(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)
(if* header
then ; header and no value
(setq value "")
(return :start))
(setq state 1)
(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
(setq state 1)
(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: ")
(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
#+(or (and allegro (version>= 6 0))
(not allegro))
(defvar *keyword-package* (find-package :keyword))
(defun kwd-intern-possible-list (form)
(if* (null form)
then nil
elseif (atom form)
then (kwd-intern form)
else (mapcar #'kwd-intern-possible-list form)))
(defun kwd-intern (string)
;; convert the string to the current preferred case
;; and then intern
(intern (case excl::*current-case-mode*
((:case-sensitive-lower
:case-insensitive-lower) (string-downcase string))
(t (string-upcase string)))
*keyword-package*))
;; low level i/o to server
(defun get-line-from-server (mailbox)
;; Return two values: a buffer and a character count.
;; The character count includes up to but excluding the cr lf that
;; was read from the socket.
;;
;; TODO: make it able to read from ssl socket
(let* ((buff (get-line-buffer 0))
(len (length buff))
(i 0)
(p (post-office-socket mailbox))
(ch nil)
(whole-count)
)
(handler-case
(flet ((grow-buffer (size)
(let ((newbuff (get-line-buffer size)))
(dotimes (j i)
(setf (schar newbuff j) (schar buff j)))
(free-line-buffer buff)
(setq buff newbuff)
(setq len (length buff)))))
;; increase the buffer to at least size
;; this is somewhat complex to ensure that we aren't doing
;; buffer allocation within the with-timeout form, since
;; that could trigger a gc which could then cause the
;; with-timeout form to expire.
(loop
(if* whole-count
then ; we should now read in this may bytes and
; append it to this buffer
(multiple-value-bind (ans this-count)
(get-block-of-data-from-server mailbox whole-count)
; now put this data in the current buffer
(if* (> (+ i whole-count 5) len)
then ; grow the initial buffer
(grow-buffer (+ i whole-count 100)))
(dotimes (ind this-count)
(setf (schar buff i) (schar ans ind))
(incf i))
(setf (schar buff i) #\^b) ; end of inset string
(incf i)
(free-line-buffer ans)
(setq whole-count nil)
)
elseif ch
then ; we're growing the buffer holding the line data
(grow-buffer (+ len 200))
(setf (schar buff i) ch)
(incf i))
(block timeout
(mp:with-timeout ((timeout mailbox)
(po-error :timeout
:format-control "imap server failed to respond"))
;; read up to lf (lf most likely preceeded by cr)
(loop
(setq ch (read-char p))
(if* (eq #\linefeed ch)
then ; end of line. Don't save the return
(if* (and (> i 0)
(eq (schar buff (1- i)) #\return))
then ; remove #\return, replace with newline
(decf i)
(setf (schar buff i) #\newline)
)
;; must check for an extended return value which
;; is indicated by a {nnn} at the end of the line
(block count-check
(let ((ind (1- i)))
(if* (and (>= i 0) (eq (schar buff ind) #\}))
then (let ((count 0)
(mult 1))
(loop
(decf ind)
(if* (< ind 0)
then ; no of the form {nnn}
(return-from count-check))
(setf ch (schar buff ind))
(if* (eq ch #\{)
then ; must now read that many bytes
(setf (schar buff ind) #\^b)
(setq whole-count count)
(setq i (1+ ind))
(return-from timeout)
elseif (<= #.(char-code #\0)
(char-code ch)
#.(char-code #\9))
then ; is a digit
(setq count
(+ count
(* mult
(- (char-code ch)
#.(char-code #\0)))))
(setq mult (* 10 mult))
else ; invalid form, get out
(return-from count-check)))))))
(return-from get-line-from-server
(values buff i))
else ; save character
(if* (>= i len)
then ; need bigger buffer
(return))
(setf (schar buff i) ch)
(incf i)))))))
(error (con)
;; most likely error is that the server went away
(ignore-errors (close p))
(po-error :server-shutdown-connection
:format-control "condition signalled: ~a~%most likely server shut down the connection."
:format-arguments (list con)))
)))
(defun get-block-of-data-from-server (mb count &key save-returns)
;; read count bytes from the server returning it in a line buffer object
;; return as a second value the number of characters saved
;; (we drop #\return's so that lines are separated by a #\newline
;; like lisp likes).
;;
(let ((buff (get-line-buffer count))
(p (post-office-socket mb))
(ind 0))
(mp:with-timeout ((timeout mb)
(po-error :timeout
:format-control "imap server timed out"))
(dotimes (i count)
(if* (eq #\return (setf (schar buff ind) (read-char p)))
then (if* save-returns then (incf ind)) ; drop #\returns
else (incf ind)))
(values buff ind))))
;;-- reusable line buffers
(defvar *line-buffers* nil)
#+(and allegro (version>= 8 1))
(defvar *line-buffers-lock* (make-basic-lock :name "line-buffers"))
(defmacro with-locked-line-buffers (&rest body)
#+(and allegro (version>= 8 1))
`(with-locked-structure (*line-buffers-lock*
:non-smp :without-scheduling)
,@body)
#-(and allegro (version>= 8 1))
`(mp:without-scheduling ,@body)
)
(defun get-line-buffer (size)
;; get a buffer of at least size bytes
(setq size (min size (1- array-total-size-limit)))
(let ((found
(with-locked-line-buffers
(dolist (buff *line-buffers*)
(if* (>= (length buff) size)
then ;; use this one
(setq *line-buffers* (delete buff *line-buffers*))
(return buff))))))
(or found (make-string size))))
(defun free-line-buffer (buff)
(with-locked-line-buffers
(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)))
;; utility
(defmacro with-imap-connection ((mb &rest options) &body body)
`(let ((,mb (make-imap-connection ,@options)))
(unwind-protect
(progn
,@body)
(close-connection ,mb))))
(defmacro with-pop-connection ((mb &rest options) &body body)
`(let ((,mb (make-pop-connection ,@options)))
(unwind-protect
(progn
,@body)
(close-connection ,mb))))