(defclass post-office ()
((socket :initarg :socket
- :accessor post-office-socket)
-
+ :accessor post-office-socket)
+
(host :initarg :host
- :accessor post-office-host
- :initform nil)
+ :accessor post-office-host
+ :initform nil)
(user :initarg :user
- :accessor post-office-user
- :initform nil)
-
+ :accessor post-office-user
+ :initform nil)
+
(state :accessor post-office-state
- :initarg :state
- :initform :unconnected)
-
- (timeout
+ :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)
+ :accessor timeout)
))
(defclass imap-mailbox (post-office)
:accessor mailbox-name
:initform nil)
- (separator
+ (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
+ :accessor mailbox-uidvalidity
:initform 0)
-
- (uidnext
+
+ (uidnext
:accessor mailbox-uidnext ;; predicted next uid
:initform 0)
-
- (flags ; list of flags that can be stored in a message
- :accessor mailbox-flags
+
+ (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
)
)
name ;; often the person's full name
additional
mailbox ;; the login name
- host ;; the name of the machine
+ host ;; the name of the machine
)
; 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
+; 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
-;
+; 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).
-;
+; 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.
+; 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.
+; the server responded with some untagged command we don't
+; recognize. it's probaby ok to ignore this.
;
; :error-response error
-; the command failed.
+; the command failed.
;
; :syntax-error error
-; the data passed to a function in this interface was malformed
+; the data passed to a function in this interface was malformed
;
; :unexpected error
-; the server responded an unexpected way.
+; the server responded an unexpected way.
;
; :server-shutdown-connection error
-; the server has shut down the connection, don't attempt to
+; 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
+; 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.
+; 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
+ ((identifier
;; keyword identifying the error (or :unknown)
- :reader po-condition-identifier
+ :reader po-condition-identifier
:initform :unknown
:initarg :identifier
)
- (server-string
+ (server-string
;; message from the imap server
:reader po-condition-server-string
:initform ""
(:report
(lambda (con stream)
(with-slots (identifier server-string) con
- ;; a condition either has a server-string or it has a
+ ;; 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)))
+ (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)))))))
-
-
+ then (format stream
+ "~&Message from server: ~s"
+ (string-left-trim " " server-string)))))))
-(define-condition po-error (po-condition error)
+
+
+(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)
+(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
- )))
-
+ :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)
+ format-control format-arguments)
(error (make-instance 'po-error
- :identifier identifier
- :server-string server-string
- :format-control format-control
- :format-arguments format-arguments)))
+ :identifier identifier
+ :server-string server-string
+ :format-control format-control
+ :format-arguments format-arguments)))
+
-
;----------------------------------------------
(setf (aref str 1) #\linefeed)
str))
-(defun make-imap-connection (host &key (port 143)
- user
- password
- (timeout 30))
+(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)))
-
+ :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)
+ (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)))
-
+ 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")))
-
+ (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))))
-
-
-
+ (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")))))
+ (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))
(let ((sock (post-office-socket pb)))
(if* sock
then (ignore-errors
- (send-pop-command-get-results
- pb
- "QUIT")))
+ (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))
+ 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)))
-
+ :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)
+ (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")))
-
+ 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)
+
+(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*)
+ "~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))
+ "~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))))))
+ (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 ()
(if* tag
thenret
else (setq *cur-imap-tags* *imap-tags*)
- (pop *cur-imap-tags*))))
+ (pop *cur-imap-tags*))))
(defun handle-untagged-response (mb command count extra comment)
- ;; default function to handle untagged responses, which are
+ ;; default function to handle untagged responses, which are
;; really just returning general state information about
;; the mailbox
(case command
(: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"))
+ :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))))
+ 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
+ ;; 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
;;
(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))
+ (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))
+ :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)))
+ ;; 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
+ ;; 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)
(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))))
+ (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))
+ (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
- ))
+ (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
+ (send-command-get-results
mb
(format nil "~afetch ~a ~a"
- (if* uid then "uid " else "")
- (message-set-string number)
- (or parts "body[]")
- )
+ (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)))
+ (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))))
+ (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
+ ;; given the information from a fetch-letter, return the
;; particular field for the particular letter
;;
;; info is as returned by fetch
;; 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))))
-
+ 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))))))))
+ 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
+ ;; 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)))
-
+ (return)))
+
stuff)
-
+
(defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid)
- ;; delete all the mesasges and do the expunge to make
+ ;; 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)))
;; 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))))
+
+ (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)))
-
+ :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))
+ (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)))
+ (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)))))
-
-
-
-
+ :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"))))
+ "noop"
+ #'handle-untagged-response
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment
+ "noop"))))
(defmethod noop ((pb pop-mailbox))
(defmethod unique-id ((pb pop-mailbox) &optional message)
;; if message is given, return the unique id of that
- ;; message,
+ ;; 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))
+ (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)))))
+ (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
- )))
+ (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)))
+ :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")))
-
+ (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
-
-
+
+
))
;; 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")))
+ (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)
;; 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"))))
+ (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"))))
+ (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)
+ messages &key (flags nil flags-p)
+ add-flags remove-flags
+ silent uid)
;;
;; change the flags using the store command
;;
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")))
+ (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)))))
-
-
-
-
-
-
+ (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")))
+ "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")))
+ "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)
+ &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")))
+ (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)
(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")))
+ (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)
(if* (null search)
then ""
else (let ((str (make-string-output-stream)))
- (bss-int search str)
- (get-output-stream-string str))))
+ (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))))
-
- ))))
-
+ (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)))
+ 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))))))
+ (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)
+ (format str "~s" search)
else (po-error :syntax-error
- :format-control "Illegal form ~s in search string"
- :format-arguments (list search)))))
+ :format-control "Illegal form ~s in search string"
+ :format-arguments (list search)))))
-(defun parse-mail-header (text)
+(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)
+ (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)))))))
-
-
-
+ ;; 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)))))))
+ (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))))
+ (subseq text next end))))
(defun make-envelope-from-text (text)
;; 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))
: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*
+ (if* *debug-imap*
then (format t "from server: ")
- (dotimes (i count)(write-char (schar line i)))
- (terpri)
- (force-output))
-
+ (dotimes (i count)(write-char (schar line i)))
+ (terpri)
+ (force-output))
+
(parse-imap-response line count)
))
;; read the next line from the pop server
;;
;; return 3 values:
- ;; :ok or :error
+ ;; :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*
+
+ (if* *debug-imap*
then (format t "from server: " count)
- (dotimes (i count)(write-char (schar line i)))
- (terpri))
-
+ (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
+;; 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)
+;; 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)
-
+ 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)))
+ 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)
- )))
-
+ :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)))))
+ (: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))
-
+ (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)))
-
+ ((: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)))
+ 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)
;; 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"))
+ (: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"))))))
+ (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")))))
+ :format-control "bad sexpression")))))
(defun parse-pop-response (line end)
;; return 3 values:
- ;; :ok or :error
+ ;; :ok or :error
;; a list of rest of the tokens on the line, the tokens
- ;; being either strings or integers
+ ;; 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)
-
+ (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))))
-
+ (: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))))
-
+ (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))
-
+ ((> 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
+ ;; :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
+ 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)))
-
+ 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)))
-
-
- )
-
+ (: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*))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+ #-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)))))))
+ (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)))
+ ;; 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
+ ;; 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))
+ (p (post-office-socket mb))
+ (ind 0))
(with-timeout ((timeout mb)
- (po-error :timeout
- :format-control "imap server timed out"))
-
+ (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)))
-
-
+ (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)
(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)))))
+ (if* (>= (length buff) size)
+ then ; use this one
+ (setq *line-buffers* (delete buff *line-buffers*))
+ (return buff)))))
(defun free-line-buffer (buff)
(setf (schar new i) (schar old i))))
-
+
;;;;;;;
(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)))
-
-
-
-
+ date
+ (svref
+ '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
+ "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+ month
+ )
+ year)))
+
+
+
+
;;
;; smtp.cl
;;
-;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
+;; 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 GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the AllegroServe
;; prequel found in license-allegroserve.txt.
;;
;; 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
+;; 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,
+;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;;
;;
;; the exported functions:
-;; (send-letter "mail-server" "from" "to" "message"
-;; &key cc bcc subject reply-to headers)
-;;
-;;
+;; (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.
+;; 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.
+;; 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.
+;; to be created.
;; headers is a string or list of stings. These are raw header lines
-;; added to the header build to send out.
+;; added to the header build to send out.
;;
-;; This builds a header and inserts the optional cc, bcc,
+;; This builds a header and inserts the optional cc, bcc,
;; subject and reply-to lines.
;;
;; (send-smtp "mail-server" "from" "to" &rest messages)
;; 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))
+ `(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))))
+ ,@case-clauses))))
(defvar *smtp-debug* nil)
(defun send-letter (server from to message
- &key cc bcc subject reply-to headers)
+ &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))))
+ (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)
+ from
+ #\return
+ #\linefeed)
(format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed)
- (if* ccs
+ (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)))
-
+ 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)))
-
-
-
-
+ (get-output-stream-string header)
+ message)))
+
+
+
+
(defun send-smtp (server from to &rest messages)
;; send the effective concatenation of the messages via
;;
(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))))
+ (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
+ ;; returning a socket connected to it and
;; signaling an error if it can't be made.
(let ((ipaddr (determine-mail-server server))
- (sock)
- (ok))
-
+ (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
- ))
+ :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))
-
+ (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)))
-
+ (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)))
+ (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")
+ 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)))))
-
+ (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)))))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+ (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
+ ;; 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.
;; 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)))))
+ ;; 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)))
+ :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)))
+ 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:
;;
(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))))
+ 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))))))))
+ (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*))
+ (force-output *smtp-debug*))
(write-string command stream)
(write-char #\return stream)
(write-char #\newline stream)
(loop
(setq ch (read-char stream nil nil))
(if* (null ch)
- then ; premature eof
- (return nil))
+ then ; premature eof
+ (return nil))
(if* *smtp-debug*
- then (format *smtp-debug* "~c" ch)
- (force-output *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))
+ 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)
+ 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))
+ 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
+ ;; 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 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)))
+ (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)))
+ (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)
projects / postoffice.git / commitdiff