1 ;; -*- mode: common-lisp; package: net.post-office -*-
4 ;; imap and pop interface
6 ;; copyright (c) 1999 Franz Inc, Berkeley, CA - All rights reserved.
8 ;; The software, data and information contained herein are proprietary
9 ;; to, and comprise valuable trade secrets of, Franz, Inc. They are
10 ;; given in confidence by Franz, Inc. pursuant to a written license
11 ;; agreement, and may be stored and used only in accordance with the terms
14 ;; Restricted Rights Legend
15 ;; ------------------------
16 ;; Use, duplication, and disclosure of the software, data and information
17 ;; contained herein by any agency, department or entity of the U.S.
18 ;; Government are subject to restrictions of Restricted Rights for
19 ;; Commercial Software developed at private expense as specified in
20 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
22 ;; $Id: imap.lisp,v 1.2 2003/05/31 13:41:10 kevin Exp $
27 ;;- This code in this file obeys the Lisp Coding Standard found in
28 ;;- http://www.franz.com/~jkf/coding_standards.html
32 (in-package :net.post-office)
36 (defparameter *imap-version-number* '(:major 1 :minor 8)) ; major.minor
39 ;; have the list of tags selected done on a per connection basis to
40 ;; eliminate any possible multithreading problems
44 (defvar *debug-imap* nil)
50 (defclass post-office ()
51 ((socket :initarg :socket
52 :accessor post-office-socket)
55 :accessor post-office-host
58 :accessor post-office-user
61 (state :accessor post-office-state
63 :initform :unconnected)
66 ;; time to wait for network activity for actions that should
67 ;; happen very quickly when things are operating normally
73 (defclass imap-mailbox (post-office)
74 ((mailbox-name ; currently selected mailbox
75 :accessor mailbox-name
79 ;; string that separates mailbox names in the hierarchy
80 :accessor mailbox-separator
83 ;;; these slots hold information about the currently selected mailbox:
85 (message-count ; how many in the mailbox
86 :accessor mailbox-message-count
89 (recent-messages ; how many messages since we last checked
90 :accessor mailbox-recent-messages
93 (uidvalidity ; used to denote messages uniquely
94 :accessor mailbox-uidvalidity
98 :accessor mailbox-uidnext ;; predicted next uid
101 (flags ; list of flags that can be stored in a message
102 :accessor mailbox-flags
105 (permanent-flags ; list of flags that be stored permanently
106 :accessor mailbox-permanent-flags
109 (first-unseen ; number of the first unseen message
110 :accessor first-unseen
113 ;;; end list of values for the currently selected mailbox
118 (defclass pop-mailbox (post-office)
119 ((message-count ; how many in the mailbox
120 :accessor mailbox-message-count
125 (defstruct (mailbox-list (:type list))
126 ;; a list of these are returned by mailbox-list
133 (defstruct (envelope (:type list))
134 ;; returned by fetch-letter as the value of the envelope property
147 (defstruct (address (:type list))
148 name ;; often the person's full name
150 mailbox ;; the login name
151 host ;; the name of the machine
156 ;--------------------------------
159 ; We define a set of conditions that are signalled due to events
160 ; in the imap interface.
161 ; Each condition has an indentifier which is a keyword. That can
162 ; be used in the handling code to identify the class of error.
163 ; All our conditions are po-condition or po-error (which is a subclass of
166 ; A condition will have a server-string value if it as initiated by
167 ; something returned by the server.
168 ; A condition will have a format-control value if we want to display
169 ; something we generated in response to
173 ;; identifiers used in conditions/errors
176 ; the server responded with 'no' followed by an explanation.
177 ; this mean that something unusual happend and doesn't necessarily
178 ; mean that the command has completely failed (but it might).
180 ; :unknown-ok condition
181 ; the server responded with an 'ok' followed by something
182 ; we don't recognize. It's probably safe to ignore this.
184 ; :unknown-untagged condition
185 ; the server responded with some untagged command we don't
186 ; recognize. it's probaby ok to ignore this.
188 ; :error-response error
189 ; the command failed.
191 ; :syntax-error error
192 ; the data passed to a function in this interface was malformed
195 ; the server responded an unexpected way.
197 ; :server-shutdown-connection error
198 ; the server has shut down the connection, don't attempt to
199 ; send any more commands to this connection, or even close it.
202 ; server failed to respond within the timeout period
204 ; :response-too-large error
205 ; contents of a response is too large to store in a Lisp array.
209 (define-condition po-condition ()
210 ;; used to notify user of things that shouldn't necessarily stop
213 ;; keyword identifying the error (or :unknown)
214 :reader po-condition-identifier
219 ;; message from the imap server
220 :reader po-condition-server-string
222 :initarg :server-string
226 (with-slots (identifier server-string) con
227 ;; a condition either has a server-string or it has a
228 ;; format-control string
229 (format stream "Post Office condition: ~s~%" identifier)
230 (if* (and (slot-boundp con 'excl::format-control)
231 (excl::simple-condition-format-control con))
232 then (apply #'format stream
233 (excl::simple-condition-format-control con)
234 (excl::simple-condition-format-arguments con)))
237 "~&Message from server: ~s"
238 (string-left-trim " " server-string)))))))
242 (define-condition po-error (po-condition error)
243 ;; used to denote things that should stop program flow
248 ;; aignalling the conditions
250 (defun po-condition (identifier &key server-string format-control
252 (signal (make-instance 'po-condition
253 :identifier identifier
254 :server-string server-string
255 :format-control format-control
256 :format-arguments format-arguments
259 (defun po-error (identifier &key server-string
260 format-control format-arguments)
261 (error (make-instance 'po-error
262 :identifier identifier
263 :server-string server-string
264 :format-control format-control
265 :format-arguments format-arguments)))
269 ;----------------------------------------------
276 (defparameter *imap-tags* '("t01" "t02" "t03" "t04" "t05" "t06" "t07"))
277 (defvar *cur-imap-tags* nil)
280 (let ((str (make-string 2)))
281 (setf (aref str 0) #\return)
282 (setf (aref str 1) #\linefeed)
285 (defun make-imap-connection (host &key (port 143)
289 (let* ((sock (make-socket :remote-host host
291 (imap (make-instance 'imap-mailbox
295 :state :unauthorized)))
297 (multiple-value-bind (tag cmd count extra comment)
298 (get-and-parse-from-imap-server imap)
299 (declare (ignore cmd count extra))
300 (if* (not (eq :untagged tag))
301 then (po-error :error-response
302 :server-string comment)))
305 (send-command-get-results imap
306 (format nil "login ~a ~a" user password)
307 #'handle-untagged-response
308 #'(lambda (mb command count extra comment)
309 (check-for-success mb command count extra
313 ; find the separator character
314 (let ((res (mailbox-list imap)))
316 (let ((sep (cadr (car res))))
318 then (setf (mailbox-separator imap) sep))))
325 (defmethod close-connection ((mb imap-mailbox))
327 (let ((sock (post-office-socket mb)))
330 (send-command-get-results
333 ; don't want to get confused by untagged
334 ; bye command, which is expected here
335 #'(lambda (mb command count extra)
336 (declare (ignore mb command count extra))
338 #'(lambda (mb command count extra comment)
339 (check-for-success mb command count extra
342 (setf (post-office-socket mb) nil)
343 (if* sock then (ignore-errors (close sock)))
347 (defmethod close-connection ((pb pop-mailbox))
348 (let ((sock (post-office-socket pb)))
351 (send-pop-command-get-results
354 (setf (post-office-socket pb) nil)
355 (if* sock then (ignore-errors (close sock)))
360 (defun make-pop-connection (host &key (port 110)
364 (let* ((sock (make-socket :remote-host host
366 (pop (make-instance 'pop-mailbox
370 :state :unauthorized)))
372 (multiple-value-bind (result)
373 (get-and-parse-from-pop-server pop)
374 (if* (not (eq :ok result))
375 then (po-error :error-response
377 "unexpected line from server after connect")))
380 (send-pop-command-get-results pop (format nil "user ~a" user))
381 (send-pop-command-get-results pop (format nil "pass ~a" password))
383 (let ((res (send-pop-command-get-results pop "stat")))
384 (setf (mailbox-message-count pop) (car res)))
391 (defmethod send-command-get-results ((mb imap-mailbox)
392 command untagged-handler tagged-handler)
393 ;; send a command and retrieve results until we get the tagged
394 ;; response for the command we sent
396 (let ((tag (get-next-tag)))
397 (format (post-office-socket mb)
398 "~a ~a~a" tag command *crlf*)
399 (force-output (post-office-socket mb))
403 "~a ~a~a" tag command *crlf*)
406 (multiple-value-bind (got-tag cmd count extra comment)
407 (get-and-parse-from-imap-server mb)
408 (if* (eq got-tag :untagged)
409 then (funcall untagged-handler mb cmd count extra comment)
410 elseif (equal tag got-tag)
411 then (funcall tagged-handler mb cmd count extra comment)
413 else (po-error :error-response
414 :format-control "received tag ~s out of order"
415 :format-arguments (list got-tag)
416 :server-string comment))))))
419 (defun get-next-tag ()
420 (let ((tag (pop *cur-imap-tags*)))
423 else (setq *cur-imap-tags* *imap-tags*)
424 (pop *cur-imap-tags*))))
426 (defun handle-untagged-response (mb command count extra comment)
427 ;; default function to handle untagged responses, which are
428 ;; really just returning general state information about
431 (:exists (setf (mailbox-message-count mb) count))
432 (:recent (setf (mailbox-recent-messages mb) count))
433 (:flags (setf (mailbox-flags mb) (mapcar #'kwd-intern extra)))
434 (:bye ; occurs when connection times out or mailbox lock is stolen
435 (ignore-errors (close (post-office-socket mb)))
436 (po-error :server-shutdown-connection
437 :server-string "server shut down the connection"))
438 (:no ; used when grabbing a lock from another process
439 (po-condition :problem :server-string comment))
440 (:ok ; a whole variety of things
442 then (if* (equalp (car extra) "unseen")
443 then (setf (first-unseen mb) (cadr extra))
444 elseif (equalp (car extra) "uidvalidity")
445 then (setf (mailbox-uidvalidity mb) (cadr extra))
446 elseif (equalp (car extra) "uidnext")
447 then (setf (mailbox-uidnext mb) (cadr extra))
448 elseif (equalp (car extra) "permanentflags")
449 then (setf (mailbox-permanent-flags mb)
450 (mapcar #'kwd-intern (cadr extra)))
451 else (po-condition :unknown-ok :server-string comment))))
452 (t (po-condition :unknown-untagged :server-string comment)))
458 (defun send-pop-command-get-results (pop command &optional extrap)
459 ;; send the given command to the pop server
460 ;; if extrap is true and if the response is +ok, then data
461 ;; will follow the command (up to and excluding the first line consisting
464 ;; if the pop server returns an error code we signal a lisp error.
467 ;; extrap is nil -- return the list of tokens on the line after +ok
468 ;; extrap is true -- return the extra object (a big string)
470 (format (post-office-socket pop) "~a~a" command *crlf*)
471 (force-output (post-office-socket pop))
474 then (format t "~a~a" command *crlf*)
477 (multiple-value-bind (result parsed line)
478 (get-and-parse-from-pop-server pop)
479 (if* (not (eq result :ok))
480 then (po-error :error-response
481 :server-string line))
484 then ;; get the rest of the data
485 ;; many but not all pop servers return the size of the data
486 ;; after the +ok, so we use that to initially size the
488 (let ((buf (get-line-buffer (+ (if* (fixnump (car parsed))
490 else 2048 ; reasonable size
496 ; 2 - seen dot at beginning of line
497 ; 3 - seen regular char on line
499 (sock (post-office-socket pop)))
500 (flet ((add-to-buffer (ch)
501 (if* (>= pos (length buf))
503 (if* (>= (length buf)
504 (1- array-total-size-limit))
505 then ; can't grow it any further
509 "response from mail server is too large to hold in a lisp array"))
510 (let ((new-buf (get-line-buffer
511 (* (length buf) 2))))
512 (init-line-buffer new-buf buf)
513 (free-line-buffer buf)
515 (setf (schar buf pos) ch)
518 (let ((ch (read-char sock nil nil)))
520 then (po-error :unexpected
521 :format-control "premature end of file from server"))
522 (if* (eq ch #\return)
527 elseif (eq ch #\linefeed)
528 then (add-to-buffer ch)
530 else (add-to-buffer ch)
533 (if* (eq ch #\linefeed)
534 then ; end of message
536 else (add-to-buffer ch)
540 (if* (eq ch #\linefeed)
541 then (setq state 1))))))))
542 (prog1 (subseq buf 0 pos)
543 (free-line-buffer buf)))
549 (defun convert-flags-plist (plist)
550 ;; scan the plist looking for "flags" indicators and
551 ;; turn value into a list of symbols rather than strings
552 (do ((xx plist (cddr xx)))
554 (if* (equalp "flags" (car xx))
555 then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))))))
558 (defmethod select-mailbox ((mb imap-mailbox) name)
559 ;; select the given mailbox
560 (send-command-get-results mb
561 (format nil "select ~a" name)
562 #'handle-untagged-response
563 #'(lambda (mb command count extra comment)
564 (declare (ignore mb count extra))
565 (if* (not (eq command :ok))
569 "imap mailbox select failed"
570 :server-string comment))))
571 (setf (mailbox-name mb) name)
576 (defmethod fetch-letter ((mb imap-mailbox) number &key uid)
577 ;; return the whole letter
578 (fetch-field number "body[]"
579 (fetch-parts mb number "body[]" :uid uid)
583 (defmethod fetch-letter ((pb pop-mailbox) number &key uid)
584 (declare (ignore uid))
585 (send-pop-command-get-results pb
586 (format nil "RETR ~d" number)
590 (defmethod fetch-parts ((mb imap-mailbox) number parts &key uid)
592 (send-command-get-results
594 (format nil "~afetch ~a ~a"
595 (if* uid then "uid " else "")
596 (message-set-string number)
599 #'(lambda (mb command count extra comment)
600 (if* (eq command :fetch)
601 then (push (list count (internalize-flags extra)) res)
602 else (handle-untagged-response
603 mb command count extra comment)))
604 #'(lambda (mb command count extra comment)
605 (declare (ignore mb count extra))
606 (if* (not (eq command :ok))
607 then (po-error :problem
608 :format-control "imap mailbox fetch failed"
609 :server-string comment))))
613 (defun fetch-field (letter-number field-name info &key uid)
614 ;; given the information from a fetch-letter, return the
615 ;; particular field for the particular letter
617 ;; info is as returned by fetch
618 ;; field-name is a string, case doesn't matter.
621 ;; item is (messagenumber plist-info)
622 ;; the same messagenumber may appear in multiple items
625 then ; uid appears as a property in the value, not
626 ; as the top level message sequence number
627 (do ((xx (cadr item) (cddr xx)))
629 (if* (equalp "uid" (car xx))
630 then (if* (eql letter-number (cadr xx))
631 then (return (setq use-this t))
633 else ; just a message sequence number
634 (setq use-this (eql letter-number (car item))))
637 then (do ((xx (cadr item) (cddr xx)))
639 (if* (equalp field-name (car xx))
640 then (return-from fetch-field (cadr xx))))))))
644 (defun internalize-flags (stuff)
645 ;; given a plist like object, look for items labelled "flags" and
646 ;; convert the contents to internal flags objects
647 (do ((xx stuff (cddr xx)))
649 (if* (equalp (car xx) "flags")
650 then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx)))
658 (defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid)
659 ;; delete all the mesasges and do the expunge to make
660 ;; it permanent if expunge is true
661 (alter-flags mb messages :add-flags :\\deleted :uid uid)
662 (if* expunge then (expunge-mailbox mb)))
664 (defmethod delete-letter ((pb pop-mailbox) messages &key (expunge nil) uid)
665 ;; delete all the messages. We can't expunge without quitting so
667 (declare (ignore expunge uid))
669 (if* (or (numberp messages)
670 (and (consp messages) (eq :seq (car messages))))
671 then (setq messages (list messages)))
673 (if* (not (consp messages))
674 then (po-error :syntax-error
675 :format-control "expect a mesage number or list of messages, not ~s"
676 :format-arguments (list messages)))
678 (dolist (message messages)
679 (if* (numberp message)
680 then (send-pop-command-get-results pb
681 (format nil "DELE ~d" message))
682 elseif (and (consp message) (eq :seq (car message)))
683 then (do ((start (cadr message) (1+ start))
684 (end (caddr message)))
686 (send-pop-command-get-results pb
687 (format nil "DELE ~d" start)))
688 else (po-error :syntax-error
689 :format-control "bad message number ~s"
690 :format-arguments (list message)))))
696 (defmethod noop ((mb imap-mailbox))
697 ;; just poke the server... keeping it awake and checking for
699 (send-command-get-results mb
701 #'handle-untagged-response
702 #'(lambda (mb command count extra comment)
704 mb command count extra
709 (defmethod noop ((pb pop-mailbox))
710 ;; send the stat command instead so we can update the message count
711 (let ((res (send-pop-command-get-results pb "stat")))
712 (setf (mailbox-message-count pb) (car res)))
716 (defmethod unique-id ((pb pop-mailbox) &optional message)
717 ;; if message is given, return the unique id of that
719 ;; if message is not given then return a list of lists:
720 ;; (message unique-id)
721 ;; for all messages not marked as deleted
724 then (let ((res (send-pop-command-get-results pb
729 else ; get all of them
730 (let* ((res (send-pop-command-get-results pb "UIDL" t))
740 (multiple-value-setq (kind mnum next)
741 (get-next-token res next end))
743 (if* (eq :eof kind) then (return))
745 (if* (not (eq :number kind))
747 (po-error :unexpected
748 :format-control "uidl returned illegal message number in ~s"
749 :format-arguments (list res)))
753 (multiple-value-setq (kind mid next)
754 (get-next-token res next end))
756 (if* (eq :number kind)
757 then ; looked like a number to the tokenizer,
758 ; make it a string to be consistent
759 (setq mid (format nil "~d" mid))
760 elseif (not (eq :string kind))
761 then ; didn't find the uid
762 (po-error :unexpected
763 :format-control "uidl returned illegal message id in ~s"
764 :format-arguments (list res)))
766 (push (list mnum mid) coll))
770 (defmethod top-lines ((pb pop-mailbox) message lines)
771 ;; return the header and the given number of top lines of the message
773 (let ((res (send-pop-command-get-results pb
787 (defun check-for-success (mb command count extra comment command-string )
788 (declare (ignore mb count extra))
789 (if* (not (eq command :ok))
790 then (po-error :error-response
791 :format-control "imap ~a failed"
792 :format-arguments (list command-string)
793 :server-string comment)))
799 (defmethod mailbox-list ((mb imap-mailbox) &key (reference "") (pattern ""))
800 ;; return a list of mailbox names with respect to a given
802 (send-command-get-results mb
803 (format nil "list ~s ~s" reference pattern)
804 #'(lambda (mb command count extra comment)
805 (if* (eq command :list)
806 then (push extra res)
807 else (handle-untagged-response
808 mb command count extra
810 #'(lambda (mb command count extra comment)
812 mb command count extra
815 ;; the car of each list is a set of keywords, make that so
817 (setf (car rr) (mapcar #'kwd-intern (car rr))))
825 (defmethod create-mailbox ((mb imap-mailbox) mailbox-name)
826 ;; create a mailbox name of the given name.
827 ;; use mailbox-separator if you want to create a hierarchy
828 (send-command-get-results mb
829 (format nil "create ~s" mailbox-name)
830 #'handle-untagged-response
831 #'(lambda (mb command count extra comment)
833 mb command count extra
838 (defmethod delete-mailbox ((mb imap-mailbox) mailbox-name)
839 ;; create a mailbox name of the given name.
840 ;; use mailbox-separator if you want to create a hierarchy
841 (send-command-get-results mb
842 (format nil "delete ~s" mailbox-name)
843 #'handle-untagged-response
844 #'(lambda (mb command count extra comment)
846 mb command count extra
849 (defmethod rename-mailbox ((mb imap-mailbox) old-mailbox-name new-mailbox-name)
850 ;; create a mailbox name of the given name.
851 ;; use mailbox-separator if you want to create a hierarchy
852 (send-command-get-results mb
853 (format nil "rename ~s ~s"
856 #'handle-untagged-response
857 #'(lambda (mb command count extra comment)
859 mb command count extra
865 (defmethod alter-flags ((mb imap-mailbox)
866 messages &key (flags nil flags-p)
867 add-flags remove-flags
870 ;; change the flags using the store command
874 then (setq cmd "flags" val flags)
876 then (setq cmd "+flags" val add-flags)
878 then (setq cmd "-flags" val remove-flags)
879 else (return-from alter-flags nil))
881 (if* (atom val) then (setq val (list val)))
883 (send-command-get-results mb
884 (format nil "~astore ~a ~a~a ~a"
885 (if* uid then "uid " else "")
886 (message-set-string messages)
894 #'(lambda (mb command count extra comment)
895 (if* (eq command :fetch)
896 then (push (list count
900 else (handle-untagged-response
901 mb command count extra
904 #'(lambda (mb command count extra comment)
906 mb command count extra
911 (defun message-set-string (messages)
912 ;; return a string that describes the messages which may be a
913 ;; single number or a sequence of numbers
916 then (format nil "~a" messages)
917 else (if* (and (consp messages)
918 (eq :seq (car messages)))
919 then (format nil "~a:~a" (cadr messages) (caddr messages))
920 else (let ((str (make-string-output-stream))
922 (dolist (msg messages)
923 (if* precomma then (format str ","))
925 then (format str "~a" msg)
926 elseif (eq :seq (car msg))
928 "~a:~a" (cadr msg) (caddr msg))
929 else (po-error :syntax-error
930 :format-control "bad message list ~s"
931 :format-arguments (list msg)))
933 (get-output-stream-string str)))))
940 (defmethod expunge-mailbox ((mb imap-mailbox))
941 ;; remove messages marked as deleted
943 (send-command-get-results mb
945 #'(lambda (mb command count extra
947 (if* (eq command :expunge)
948 then (push count res)
949 else (handle-untagged-response
950 mb command count extra
952 #'(lambda (mb command count extra comment)
954 mb command count extra
960 (defmethod close-mailbox ((mb imap-mailbox))
961 ;; remove messages marked as deleted
962 (send-command-get-results mb
964 #'handle-untagged-response
966 #'(lambda (mb command count extra comment)
968 mb command count extra
974 (defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination
976 (send-command-get-results mb
977 (format nil "~acopy ~a ~s"
978 (if* uid then "uid " else "")
979 (message-set-string message-list)
981 #'handle-untagged-response
982 #'(lambda (mb command count extra comment)
984 mb command count extra
991 (defmethod search-mailbox ((mb imap-mailbox) search-expression &key uid)
993 (send-command-get-results mb
994 (format nil "~asearch ~a"
995 (if* uid then "uid " else "")
996 (build-search-string search-expression))
997 #'(lambda (mb command count extra comment)
998 (if* (eq command :search)
999 then (setq res (append res extra))
1000 else (handle-untagged-response
1001 mb command count extra
1003 #'(lambda (mb command count extra comment)
1005 mb command count extra
1010 (defmacro defsearchop (name &rest operands)
1011 (if* (null operands)
1012 then `(setf (get ',name 'imap-search-no-args) t)
1013 else `(setf (get ',name 'imap-search-args) ',operands)))
1016 (defsearchop :answered)
1017 (defsearchop :bcc :str)
1018 (defsearchop :before :date)
1019 (defsearchop :body :str)
1020 (defsearchop :cc :str)
1021 (defsearchop :deleted)
1022 (defsearchop :draft)
1023 (defsearchop :flagged)
1024 (defsearchop :from :str)
1025 (defsearchop :header :str :str)
1026 (defsearchop :keyword :flag)
1027 (defsearchop :larger :number)
1030 (defsearchop :on :date)
1031 (defsearchop :recent)
1033 (defsearchop :sentbefore :date)
1034 (defsearchop :senton :date)
1035 (defsearchop :sentsince :date)
1036 (defsearchop :since :date)
1037 (defsearchop :smaller :number)
1038 (defsearchop :subject :str)
1039 (defsearchop :text :str)
1040 (defsearchop :to :str)
1041 (defsearchop :uid :messageset)
1042 (defsearchop :unanswered)
1043 (defsearchop :undeleted)
1044 (defsearchop :undraft)
1045 (defsearchop :unflagged)
1046 (defsearchop :unkeyword :flag)
1047 (defsearchop :unseen)
1051 (defun build-search-string (search)
1052 ;; take the lisp search form and turn it into a string that can be
1057 else (let ((str (make-string-output-stream)))
1058 (bss-int search str)
1059 (get-output-stream-string str))))
1061 (defun bss-int (search str)
1062 ;;* it turns out that imap (on linux) is very picky about spaces....
1063 ;; any extra whitespace will result in failed searches
1065 (labels ((and-ify (srch str)
1066 (let ((spaceout nil))
1068 (if* spaceout then (format str " "))
1070 (setq spaceout t))))
1072 ; only binary or allowed in imap but we support n-ary
1073 ; or in this interface
1074 (if* (null (cdr srch))
1075 then (bss-int (car srch) str)
1077 then ; over two clauses
1079 (bss-int (car srch) str)
1081 (or-ify (cdr srch) str)
1084 (format str "or (" )
1085 (bss-int (car srch) str)
1087 (bss-int (cadr srch) str)
1090 ;; a sequence of messages
1091 (do* ((xsrch srch (cdr xsrch))
1092 (val (car xsrch) (car xsrch)))
1095 then (format str "~s" val)
1096 elseif (and (consp val)
1098 (eq 3 (length val)))
1099 then (format str "~s:~s" (cadr val) (caddr val))
1100 else (po-error :syntax-error
1101 :format-control "illegal set format ~s"
1102 :format-arguments (list val)))
1103 (if* (cdr xsrch) then (format str ","))))
1104 (arg-process (str args arginfo)
1105 ;; process and print each arg to str
1106 ;; assert (length of args and arginfo are the same)
1107 (do* ((x-args args (cdr x-args))
1108 (val (car x-args) (car x-args))
1109 (x-arginfo arginfo (cdr x-arginfo)))
1111 (ecase (car x-arginfo)
1113 ; print it as a string
1114 (format str " \"~a\"" (car x-args)))
1118 then (setq val (universal-time-to-rfc822-date
1120 elseif (not (stringp val))
1121 then (po-error :syntax-error
1122 :format-control "illegal value for date search ~s"
1123 :format-arguments (list val)))
1124 ;; val is now a string
1125 (format str " ~s" val))
1128 (if* (not (integerp val))
1129 then (po-error :syntax-error
1130 :format-control "illegal value for number in search ~s"
1131 :format-arguments (list val)))
1132 (format str " ~s" val))
1135 ;; should be a symbol in the kwd package
1136 (setq val (string val))
1137 (format str " ~s" val))
1140 then (format str " ~s" val)
1142 then (set-ify val str)
1143 else (po-error :syntax-error
1144 :format-control "illegal message set ~s"
1145 :format-arguments (list val))))
1149 (if* (symbolp search)
1150 then (if* (get search 'imap-search-no-args)
1151 then (format str "~a" (string-upcase
1153 else (po-error :syntax-error
1154 :format-control "illegal search word: ~s"
1155 :format-arguments (list search)))
1156 elseif (consp search)
1157 then (case (car search)
1158 (and (if* (null (cdr search))
1159 then (bss-int :all str)
1160 elseif (null (cddr search))
1161 then (bss-int (cadr search) str)
1162 else (and-ify (cdr search) str)))
1163 (or (if* (null (cdr search))
1164 then (bss-int :all str)
1165 elseif (null (cddr search))
1166 then (bss-int (cadr search) str)
1167 else (or-ify (cdr search) str)))
1168 (not (if* (not (eql (length search) 2))
1169 then (po-error :syntax-error
1170 :format-control "not takes one argument: ~s"
1171 :format-arguments (list search)))
1172 (format str "not (" )
1173 (bss-int (cadr search) str)
1176 (set-ify (list search) str))
1178 (if* (and (symbolp (car search))
1179 (setq arginfo (get (car search)
1180 'imap-search-args)))
1182 (format str "~a" (string-upcase
1183 (string (car search))))
1184 (if* (not (equal (length (cdr search))
1186 then (po-error :syntax-error
1187 :format-control "wrong number of arguments to ~s"
1188 :format-arguments search))
1190 (arg-process str (cdr search) arginfo)
1192 elseif (integerp (car search))
1193 then (set-ify search str)
1194 else (po-error :syntax-error
1195 :format-control "Illegal form ~s in search string"
1196 :format-arguments (list search))))))
1197 elseif (integerp search)
1198 then ; a message number
1199 (format str "~s" search)
1200 else (po-error :syntax-error
1201 :format-control "Illegal form ~s in search string"
1202 :format-arguments (list search)))))
1208 (defun parse-mail-header (text)
1209 ;; given the partial text of a mail message that includes
1210 ;; at least the header part, return an assoc list of
1211 ;; (header . content) items
1212 ;; Note that the header is string with most likely mixed case names
1213 ;; as it's conventional to capitalize header names.
1220 (labels ((next-header-line ()
1221 ;; find the next header line return
1223 ;; :start - beginning of header value, header and
1225 ;; :continue - continuation of previous header line
1229 beginv ; charpos beginning value
1230 beginh ; charpos beginning header
1235 (return-from next-header-line
1237 (loop ; for each character
1242 (setq ch (char text next))
1243 (if* (eq ch #\return)
1244 thenret ; ignore return, (handle following linefeed)
1246 (1 ; no characters seen
1247 (if* (eq ch #\linefeed)
1255 else (setq beginh next)
1258 (2 ; looking for first non blank in value
1259 (if* (eq ch #\linefeed)
1260 then ; empty continuation line, ignore
1263 elseif (not (member ch
1267 then ; begin value part
1270 (3 ; reading the header
1271 (if* (eq ch #\linefeed)
1272 then ; bogus header line, ignore
1276 (subseq text beginh next))
1278 (4 ; looking for the end of the value
1279 (if* (eq ch #\linefeed)
1290 else :continue))))))
1295 (loop ; for each header line
1297 (if* (eq :eof (setq kind (next-header-line)))
1300 (:start (push (cons header value) headers))
1303 then ; append to previous one
1304 (setf (cdr (car headers))
1305 (concatenate 'string (cdr (car headers))
1309 (subseq text next end))))
1312 (defun make-envelope-from-text (text)
1313 ;; given at least the headers part of a message return
1314 ;; an envelope structure containing the contents
1315 ;; This is useful for parsing the headers of things returned by
1318 (let ((headers (parse-mail-header text)))
1321 :date (cdr (assoc "date" headers :test #'equalp))
1322 :subject (cdr (assoc "subject" headers :test #'equalp))
1323 :from (cdr (assoc "from" headers :test #'equalp))
1324 :sender (cdr (assoc "sender" headers :test #'equalp))
1325 :reply-to (cdr (assoc "reply-to" headers :test #'equalp))
1326 :to (cdr (assoc "to" headers :test #'equalp))
1327 :cc (cdr (assoc "cc" headers :test #'equalp))
1328 :bcc (cdr (assoc "bcc" headers :test #'equalp))
1329 :in-reply-to (cdr (assoc "in-reply-to" headers :test #'equalp))
1330 :message-id (cdr (assoc "message-id" headers :test #'equalp))
1342 (defmethod get-and-parse-from-imap-server ((mb imap-mailbox))
1343 ;; read the next line and parse it
1346 (multiple-value-bind (line count)
1347 (get-line-from-server mb)
1349 then (format t "from server: ")
1350 (dotimes (i count)(write-char (schar line i)))
1354 (parse-imap-response line count)
1359 (defmethod get-and-parse-from-pop-server ((mb pop-mailbox))
1360 ;; read the next line from the pop server
1364 ;; a list of rest of the tokens on the line
1365 ;; the whole line after the +ok or -err
1367 (multiple-value-bind (line count)
1368 (get-line-from-server mb)
1371 then (format t "from server: " count)
1372 (dotimes (i count)(write-char (schar line i)))
1375 (parse-pop-response line count)))
1379 ;; Parse and return the data from each line
1381 ;; tag -- either a string or the symbol :untagged
1382 ;; command -- a keyword symbol naming the command, like :ok
1383 ;; count -- a number which preceeded the command, or nil if
1384 ;; there wasn't a command
1385 ;; bracketted - a list of objects found in []'s after the command
1386 ;; or in ()'s after the command or sometimes just
1387 ;; out in the open after the command (like the search)
1388 ;; comment -- the whole of the part after the command
1390 (defun parse-imap-response (line end)
1391 (let (kind value next
1392 tag count command extra-data
1396 (multiple-value-setq (kind value next)
1397 (get-next-token line 0 end))
1400 (:string (setq tag (if* (equal value "*")
1403 (t (po-error :unexpected
1404 :format-control "Illegal tag on response: ~s"
1405 :format-arguments (list (subseq line 0 count))
1406 :server-string (subseq line 0 end)
1410 (multiple-value-setq (kind value next)
1411 (get-next-token line next end))
1415 (:number (setq count value)
1416 (multiple-value-setq (kind value next)
1417 (get-next-token line next end))
1419 (:string (setq command (kwd-intern value)))
1420 (t (po-error :unexpected
1421 :format-control "Illegal command on response: ~s"
1422 :format-arguments (list (subseq line 0 count))
1423 :server-string (subseq line 0 end)))))
1425 (setq comment (subseq line next end))
1427 ;; now the part after the command... this gets tricky
1429 (multiple-value-setq (kind value next)
1430 (get-next-token line next end))
1433 ((:lbracket :lparen)
1434 (multiple-value-setq (kind value next)
1435 (get-next-sexpr line (1- next) end))
1437 (:sexpr (push value extra-data))
1438 (t (po-error :syntax-error :format-control "bad sexpr form"))))
1440 ((:number :string :nil) (push value extra-data))
1441 (t ; should never happen
1444 (if* (not (member command '(:list :search) :test #'eq))
1445 then ; only one item returned
1446 (setq extra-data (car extra-data))
1449 (if* (member command '(:list :search) :test #'eq)
1450 then (setq extra-data (nreverse extra-data)))
1453 (values tag command count extra-data comment)))
1457 (defun get-next-sexpr (line start end)
1458 ;; read a whole s-expression
1460 ;; kind -- :sexpr or :rparen or :rbracket
1461 ;; value - the sexpr value
1462 ;; next - next charpos to scan
1464 (let ( kind value next)
1465 (multiple-value-setq (kind value next) (get-next-token line start end))
1468 ((:string :number :nil)
1469 (values :sexpr value next))
1470 (:eof (po-error :syntax-error
1471 :format-control "eof inside sexpr"))
1472 ((:lbracket :lparen)
1475 (multiple-value-setq (kind value next)
1476 (get-next-sexpr line next end))
1478 (:sexpr (push value res))
1479 ((:rparen :rbracket)
1480 (return (values :sexpr (nreverse res) next)))
1481 (t (po-error :syntax-error
1482 :format-control "bad sexpression"))))))
1483 ((:rbracket :rparen)
1484 (values kind nil next))
1485 (t (po-error :syntax-error
1486 :format-control "bad sexpression")))))
1489 (defun parse-pop-response (line end)
1492 ;; a list of rest of the tokens on the line, the tokens
1493 ;; being either strings or integers
1494 ;; the whole line after the +ok or -err
1496 (let (res lineres result)
1497 (multiple-value-bind (kind value next)
1498 (get-next-token line 0 end)
1501 (:string (setq result (if* (equal "+OK" value)
1504 (t (po-error :unexpected
1505 :format-control "bad response from server"
1506 :server-string (subseq line 0 end))))
1508 (setq lineres (subseq line next end))
1511 (multiple-value-setq (kind value next)
1512 (get-next-token line next end))
1516 ((:string :number) (push value res))))
1518 (values result (nreverse res) lineres))))
1529 (defparameter *char-to-kind*
1530 (let ((arr (make-array 256 :initial-element nil)))
1532 (do ((i #.(char-code #\0) (1+ i)))
1533 ((> i #.(char-code #\9)))
1534 (setf (aref arr i) :number))
1536 (setf (aref arr #.(char-code #\space)) :space)
1537 (setf (aref arr #.(char-code #\tab)) :space)
1538 (setf (aref arr #.(char-code #\return)) :space)
1539 (setf (aref arr #.(char-code #\linefeed)) :space)
1541 (setf (aref arr #.(char-code #\[)) :lbracket)
1542 (setf (aref arr #.(char-code #\])) :rbracket)
1543 (setf (aref arr #.(char-code #\()) :lparen)
1544 (setf (aref arr #.(char-code #\))) :rparen)
1545 (setf (aref arr #.(char-code #\")) :dquote)
1547 (setf (aref arr #.(char-code #\^b)) :big-string) ; our own invention
1552 (defun get-next-token (line start end)
1553 ;; scan past whitespace for the next token
1554 ;; return three values:
1555 ;; kind: :string , :number, :eof, :lbracket, :rbracket,
1557 ;; value: the value, either a string or number or nil
1558 ;; next: the character pos to start scanning for the next token
1560 (let (ch chkind colstart (count 0) (state :looking)
1561 collector right-bracket-is-normal)
1563 ; pick up the next character
1565 then (if* (eq state :looking)
1566 then (return (values :eof nil start))
1567 else (setq ch #\space))
1568 else (setq ch (schar line start)))
1570 (setq chkind (aref *char-to-kind* (char-code ch)))
1576 (:number (setq state :number)
1577 (setq colstart start)
1578 (setq count (- (char-code ch) #.(char-code #\0))))
1579 ((:lbracket :lparen :rbracket :rparen)
1580 (return (values chkind nil (1+ start))))
1582 (setq collector (make-array 10
1583 :element-type 'character
1586 (setq state :qstring))
1588 (setq colstart (1+ start))
1589 (setq state :big-string))
1590 (t (setq colstart start)
1591 (setq state :literal))))
1594 ((:space :lbracket :lparen :rbracket :rparen
1595 :dquote) ; end of number
1596 (return (values :number count start)))
1597 (:number ; more number
1598 (setq count (+ (* count 10)
1599 (- (char-code ch) #.(char-code #\0)))))
1600 (t ; turn into an literal
1601 (setq state :literal))))
1604 ((:space :rbracket :lparen :rparen :dquote) ; end of literal
1605 (if* (and (eq chkind :rbracket)
1606 right-bracket-is-normal)
1607 then nil ; don't stop now
1608 else (let ((seq (subseq line colstart start)))
1609 (if* (equal "NIL" seq)
1610 then (return (values :nil
1613 else (return (values :string
1616 (t (if* (eq chkind :lbracket)
1617 then ; imbedded left bracket so right bracket isn't
1619 (setq right-bracket-is-normal t))
1623 ; (format t "start is ~s kind is ~s~%" start chkind)
1627 (return (values :string collector (1+ start))))
1629 then ; escaping the next character
1632 then (po-error :unexpected
1633 :format-control "eof in string returned"))
1634 (setq ch (schar line start)))
1635 (vector-push-extend ch collector)
1638 then ; we overran the end of the input
1639 (po-error :unexpected
1640 :format-control "eof in string returned")))))
1642 ;; super string... just a block of data
1643 ; (format t "start is ~s kind is ~s~%" start chkind)
1647 (return (values :string
1648 (subseq line colstart start)
1659 ; this used to be exported from the excl package
1660 #+(and allegro (version>= 6 0))
1661 (defvar *keyword-package* (find-package :keyword))
1664 (defun kwd-intern (string)
1665 ;; convert the string to the current preferred case
1667 (intern (case excl::*current-case-mode*
1668 ((:case-sensitive-lower
1669 :case-insensitive-lower) (string-downcase string))
1670 (t (string-upcase string)))
1686 ;; low level i/o to server
1688 (defun get-line-from-server (mailbox)
1689 ;; Return two values: a buffer and a character count.
1690 ;; The character count includes up to but excluding the cr lf that
1691 ;; was read from the socket.
1693 (let* ((buff (get-line-buffer 0))
1696 (p (post-office-socket mailbox))
1702 (flet ((grow-buffer (size)
1703 (let ((newbuff (get-line-buffer size)))
1705 (setf (schar newbuff j) (schar buff j)))
1706 (free-line-buffer buff)
1708 (setq len (length buff)))))
1710 ;; increase the buffer to at least size
1711 ;; this is somewhat complex to ensure that we aren't doing
1712 ;; buffer allocation within the with-timeout form, since
1713 ;; that could trigger a gc which could then cause the
1714 ;; with-timeout form to expire.
1718 then ; we should now read in this may bytes and
1719 ; append it to this buffer
1720 (multiple-value-bind (ans this-count)
1721 (get-block-of-data-from-server mailbox whole-count)
1722 ; now put this data in the current buffer
1723 (if* (> (+ i whole-count 5) len)
1724 then ; grow the initial buffer
1725 (grow-buffer (+ i whole-count 100)))
1727 (dotimes (ind this-count)
1728 (setf (schar buff i) (schar ans ind))
1730 (setf (schar buff i) #\^b) ; end of inset string
1732 (free-line-buffer ans)
1733 (setq whole-count nil)
1736 then ; we're growing the buffer holding the line data
1737 (grow-buffer (+ len 200))
1738 (setf (schar buff i) ch)
1743 (with-timeout ((timeout mailbox)
1745 :format-control "imap server failed to respond"))
1746 ;; read up to lf (lf most likely preceeded by cr)
1748 (setq ch (read-char p))
1749 (if* (eq #\linefeed ch)
1750 then ; end of line. Don't save the return
1752 (eq (schar buff (1- i)) #\return))
1753 then ; remove #\return, replace with newline
1755 (setf (schar buff i) #\newline)
1757 ;; must check for an extended return value which
1758 ;; is indicated by a {nnn} at the end of the line
1761 (if* (and (>= i 0) (eq (schar buff ind) #\}))
1762 then (let ((count 0)
1767 then ; no of the form {nnn}
1768 (return-from count-check))
1769 (setf ch (schar buff ind))
1771 then ; must now read that many bytes
1772 (setf (schar buff ind) #\^b)
1773 (setq whole-count count)
1775 (return-from timeout)
1776 elseif (<= #.(char-code #\0)
1784 #.(char-code #\0)))))
1785 (setq mult (* 10 mult))
1786 else ; invalid form, get out
1787 (return-from count-check)))))))
1790 (return-from get-line-from-server
1792 else ; save character
1794 then ; need bigger buffer
1796 (setf (schar buff i) ch)
1799 ;; most likely error is that the server went away
1800 (ignore-errors (close p))
1801 (po-error :server-shutdown-connection
1802 :format-control "condition signalled: ~a~%most likely server shut down the connection."
1803 :format-arguments (list con)))
1807 (defun get-block-of-data-from-server (mb count &key save-returns)
1808 ;; read count bytes from the server returning it in a line buffer object
1809 ;; return as a second value the number of characters saved
1810 ;; (we drop #\return's so that lines are sepisarated by a #\newline
1811 ;; like lisp likes).
1813 (let ((buff (get-line-buffer count))
1814 (p (post-office-socket mb))
1816 (with-timeout ((timeout mb)
1818 :format-control "imap server timed out"))
1821 (if* (eq #\return (setf (schar buff ind) (read-char p)))
1822 then (if* save-returns then (incf ind)) ; drop #\returns
1826 (values buff ind))))
1829 ;;-- reusable line buffers
1831 (defvar *line-buffers* nil)
1833 (defun get-line-buffer (size)
1834 ;; get a buffer of at least size bytes
1835 (setq size (min size (1- array-total-size-limit)))
1837 (dolist (buff *line-buffers* (make-string size))
1838 (if* (>= (length buff) size)
1840 (setq *line-buffers* (delete buff *line-buffers*))
1844 (defun free-line-buffer (buff)
1846 (push buff *line-buffers*)))
1848 (defun init-line-buffer (new old)
1849 ;; copy old into new
1850 (declare (optimize (speed 3)))
1851 (dotimes (i (length old))
1852 (declare (fixnum i))
1853 (setf (schar new i) (schar old i))))
1862 (defun universal-time-to-rfc822-date (ut)
1863 ;; convert a lisp universal time to rfc 822 date
1865 (multiple-value-bind
1866 (sec min hour date month year day-of-week dsp time-zone)
1867 (decode-universal-time ut 0)
1868 (declare (ignore time-zone sec min hour day-of-week dsp time-zone))
1869 (format nil "~d-~a-~d"
1872 '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
1873 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")