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.
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)
231 (if* (and (slot-boundp con 'excl::format-control)
232 (excl::simple-condition-format-control con))
233 then (apply #'format stream
234 (excl::simple-condition-format-control con)
235 (excl::simple-condition-format-arguments con)))
238 "~&Message from server: ~s"
239 (string-left-trim " " server-string)))))))
243 (define-condition po-error (po-condition error)
244 ;; used to denote things that should stop program flow
249 ;; aignalling the conditions
251 (defun po-condition (identifier &key server-string format-control
253 (signal (make-instance 'po-condition
254 :identifier identifier
255 :server-string server-string
256 :format-control format-control
257 :format-arguments format-arguments
260 (defun po-error (identifier &key server-string
261 format-control format-arguments)
262 (error (make-instance 'po-error
263 :identifier identifier
264 :server-string server-string
265 :format-control format-control
266 :format-arguments format-arguments)))
270 ;----------------------------------------------
277 (defparameter *imap-tags* '("t01" "t02" "t03" "t04" "t05" "t06" "t07"))
278 (defvar *cur-imap-tags* nil)
281 (let ((str (make-string 2)))
282 (setf (aref str 0) #\return)
283 (setf (aref str 1) #\linefeed)
286 (defun make-imap-connection (host &key (port 143)
290 (let* ((sock (make-socket :remote-host host
292 (imap (make-instance 'imap-mailbox
296 :state :unauthorized)))
298 (multiple-value-bind (tag cmd count extra comment)
299 (get-and-parse-from-imap-server imap)
300 (declare (ignore cmd count extra))
301 (if* (not (eq :untagged tag))
302 then (po-error :error-response
303 :server-string comment)))
306 (send-command-get-results imap
307 (format nil "login ~a ~a" user password)
308 #'handle-untagged-response
309 #'(lambda (mb command count extra comment)
310 (check-for-success mb command count extra
314 ; find the separator character
315 (let ((res (mailbox-list imap)))
317 (let ((sep (cadr (car res))))
319 then (setf (mailbox-separator imap) sep))))
326 (defmethod close-connection ((mb imap-mailbox))
328 (let ((sock (post-office-socket mb)))
331 (send-command-get-results
334 ; don't want to get confused by untagged
335 ; bye command, which is expected here
336 #'(lambda (mb command count extra)
337 (declare (ignore mb command count extra))
339 #'(lambda (mb command count extra comment)
340 (check-for-success mb command count extra
343 (setf (post-office-socket mb) nil)
344 (if* sock then (ignore-errors (close sock)))
348 (defmethod close-connection ((pb pop-mailbox))
349 (let ((sock (post-office-socket pb)))
352 (send-pop-command-get-results
355 (setf (post-office-socket pb) nil)
356 (if* sock then (ignore-errors (close sock)))
361 (defun make-pop-connection (host &key (port 110)
365 (let* ((sock (make-socket :remote-host host
367 (pop (make-instance 'pop-mailbox
371 :state :unauthorized)))
373 (multiple-value-bind (result)
374 (get-and-parse-from-pop-server pop)
375 (if* (not (eq :ok result))
376 then (po-error :error-response
378 "unexpected line from server after connect")))
381 (send-pop-command-get-results pop (format nil "user ~a" user))
382 (send-pop-command-get-results pop (format nil "pass ~a" password))
384 (let ((res (send-pop-command-get-results pop "stat")))
385 (setf (mailbox-message-count pop) (car res)))
392 (defmethod send-command-get-results ((mb imap-mailbox)
393 command untagged-handler tagged-handler)
394 ;; send a command and retrieve results until we get the tagged
395 ;; response for the command we sent
397 (let ((tag (get-next-tag)))
398 (format (post-office-socket mb)
399 "~a ~a~a" tag command *crlf*)
400 (force-output (post-office-socket mb))
404 "~a ~a~a" tag command *crlf*)
407 (multiple-value-bind (got-tag cmd count extra comment)
408 (get-and-parse-from-imap-server mb)
409 (if* (eq got-tag :untagged)
410 then (funcall untagged-handler mb cmd count extra comment)
411 elseif (equal tag got-tag)
412 then (funcall tagged-handler mb cmd count extra comment)
414 else (po-error :error-response
415 :format-control "received tag ~s out of order"
416 :format-arguments (list got-tag)
417 :server-string comment))))))
420 (defun get-next-tag ()
421 (let ((tag (pop *cur-imap-tags*)))
424 else (setq *cur-imap-tags* *imap-tags*)
425 (pop *cur-imap-tags*))))
427 (defun handle-untagged-response (mb command count extra comment)
428 ;; default function to handle untagged responses, which are
429 ;; really just returning general state information about
432 (:exists (setf (mailbox-message-count mb) count))
433 (:recent (setf (mailbox-recent-messages mb) count))
434 (:flags (setf (mailbox-flags mb) (mapcar #'kwd-intern extra)))
435 (:bye ; occurs when connection times out or mailbox lock is stolen
436 (ignore-errors (close (post-office-socket mb)))
437 (po-error :server-shutdown-connection
438 :server-string "server shut down the connection"))
439 (:no ; used when grabbing a lock from another process
440 (po-condition :problem :server-string comment))
441 (:ok ; a whole variety of things
443 then (if* (equalp (car extra) "unseen")
444 then (setf (first-unseen mb) (cadr extra))
445 elseif (equalp (car extra) "uidvalidity")
446 then (setf (mailbox-uidvalidity mb) (cadr extra))
447 elseif (equalp (car extra) "uidnext")
448 then (setf (mailbox-uidnext mb) (cadr extra))
449 elseif (equalp (car extra) "permanentflags")
450 then (setf (mailbox-permanent-flags mb)
451 (mapcar #'kwd-intern (cadr extra)))
452 else (po-condition :unknown-ok :server-string comment))))
453 (t (po-condition :unknown-untagged :server-string comment)))
459 (defun send-pop-command-get-results (pop command &optional extrap)
460 ;; send the given command to the pop server
461 ;; if extrap is true and if the response is +ok, then data
462 ;; will follow the command (up to and excluding the first line consisting
465 ;; if the pop server returns an error code we signal a lisp error.
468 ;; extrap is nil -- return the list of tokens on the line after +ok
469 ;; extrap is true -- return the extra object (a big string)
471 (format (post-office-socket pop) "~a~a" command *crlf*)
472 (force-output (post-office-socket pop))
475 then (format t "~a~a" command *crlf*)
478 (multiple-value-bind (result parsed line)
479 (get-and-parse-from-pop-server pop)
480 (if* (not (eq result :ok))
481 then (po-error :error-response
482 :server-string line))
485 then ;; get the rest of the data
486 ;; many but not all pop servers return the size of the data
487 ;; after the +ok, so we use that to initially size the
489 (let ((buf (get-line-buffer (+ (if* (fixnump (car parsed))
491 else 2048 ; reasonable size
497 ; 2 - seen dot at beginning of line
498 ; 3 - seen regular char on line
500 (sock (post-office-socket pop)))
501 (flet ((add-to-buffer (ch)
502 (if* (>= pos (length buf))
504 (if* (>= (length buf)
505 (1- array-total-size-limit))
506 then ; can't grow it any further
510 "response from mail server is too large to hold in a lisp array"))
511 (let ((new-buf (get-line-buffer
512 (* (length buf) 2))))
513 (init-line-buffer new-buf buf)
514 (free-line-buffer buf)
516 (setf (schar buf pos) ch)
519 (let ((ch (read-char sock nil nil)))
521 then (po-error :unexpected
522 :format-control "premature end of file from server"))
523 (if* (eq ch #\return)
528 elseif (eq ch #\linefeed)
529 then (add-to-buffer ch)
531 else (add-to-buffer ch)
534 (if* (eq ch #\linefeed)
535 then ; end of message
537 else (add-to-buffer ch)
541 (if* (eq ch #\linefeed)
542 then (setq state 1))))))))
543 (prog1 (subseq buf 0 pos)
544 (free-line-buffer buf)))
550 (defun convert-flags-plist (plist)
551 ;; scan the plist looking for "flags" indicators and
552 ;; turn value into a list of symbols rather than strings
553 (do ((xx plist (cddr xx)))
555 (if* (equalp "flags" (car xx))
556 then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))))))
559 (defmethod select-mailbox ((mb imap-mailbox) name)
560 ;; select the given mailbox
561 (send-command-get-results mb
562 (format nil "select ~a" name)
563 #'handle-untagged-response
564 #'(lambda (mb command count extra comment)
565 (declare (ignore mb count extra))
566 (if* (not (eq command :ok))
570 "imap mailbox select failed"
571 :server-string comment))))
572 (setf (mailbox-name mb) name)
577 (defmethod fetch-letter ((mb imap-mailbox) number &key uid)
578 ;; return the whole letter
579 (fetch-field number "body[]"
580 (fetch-parts mb number "body[]" :uid uid)
584 (defmethod fetch-letter ((pb pop-mailbox) number &key uid)
585 (declare (ignore uid))
586 (send-pop-command-get-results pb
587 (format nil "RETR ~d" number)
591 (defmethod fetch-parts ((mb imap-mailbox) number parts &key uid)
593 (send-command-get-results
595 (format nil "~afetch ~a ~a"
596 (if* uid then "uid " else "")
597 (message-set-string number)
600 #'(lambda (mb command count extra comment)
601 (if* (eq command :fetch)
602 then (push (list count (internalize-flags extra)) res)
603 else (handle-untagged-response
604 mb command count extra comment)))
605 #'(lambda (mb command count extra comment)
606 (declare (ignore mb count extra))
607 (if* (not (eq command :ok))
608 then (po-error :problem
609 :format-control "imap mailbox fetch failed"
610 :server-string comment))))
614 (defun fetch-field (letter-number field-name info &key uid)
615 ;; given the information from a fetch-letter, return the
616 ;; particular field for the particular letter
618 ;; info is as returned by fetch
619 ;; field-name is a string, case doesn't matter.
622 ;; item is (messagenumber plist-info)
623 ;; the same messagenumber may appear in multiple items
626 then ; uid appears as a property in the value, not
627 ; as the top level message sequence number
628 (do ((xx (cadr item) (cddr xx)))
630 (if* (equalp "uid" (car xx))
631 then (if* (eql letter-number (cadr xx))
632 then (return (setq use-this t))
634 else ; just a message sequence number
635 (setq use-this (eql letter-number (car item))))
638 then (do ((xx (cadr item) (cddr xx)))
640 (if* (equalp field-name (car xx))
641 then (return-from fetch-field (cadr xx))))))))
645 (defun internalize-flags (stuff)
646 ;; given a plist like object, look for items labelled "flags" and
647 ;; convert the contents to internal flags objects
648 (do ((xx stuff (cddr xx)))
650 (if* (equalp (car xx) "flags")
651 then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx)))
659 (defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid)
660 ;; delete all the mesasges and do the expunge to make
661 ;; it permanent if expunge is true
662 (alter-flags mb messages :add-flags :\\deleted :uid uid)
663 (if* expunge then (expunge-mailbox mb)))
665 (defmethod delete-letter ((pb pop-mailbox) messages &key (expunge nil) uid)
666 ;; delete all the messages. We can't expunge without quitting so
668 (declare (ignore expunge uid))
670 (if* (or (numberp messages)
671 (and (consp messages) (eq :seq (car messages))))
672 then (setq messages (list messages)))
674 (if* (not (consp messages))
675 then (po-error :syntax-error
676 :format-control "expect a mesage number or list of messages, not ~s"
677 :format-arguments (list messages)))
679 (dolist (message messages)
680 (if* (numberp message)
681 then (send-pop-command-get-results pb
682 (format nil "DELE ~d" message))
683 elseif (and (consp message) (eq :seq (car message)))
684 then (do ((start (cadr message) (1+ start))
685 (end (caddr message)))
687 (send-pop-command-get-results pb
688 (format nil "DELE ~d" start)))
689 else (po-error :syntax-error
690 :format-control "bad message number ~s"
691 :format-arguments (list message)))))
697 (defmethod noop ((mb imap-mailbox))
698 ;; just poke the server... keeping it awake and checking for
700 (send-command-get-results mb
702 #'handle-untagged-response
703 #'(lambda (mb command count extra comment)
705 mb command count extra
710 (defmethod noop ((pb pop-mailbox))
711 ;; send the stat command instead so we can update the message count
712 (let ((res (send-pop-command-get-results pb "stat")))
713 (setf (mailbox-message-count pb) (car res)))
717 (defmethod unique-id ((pb pop-mailbox) &optional message)
718 ;; if message is given, return the unique id of that
720 ;; if message is not given then return a list of lists:
721 ;; (message unique-id)
722 ;; for all messages not marked as deleted
725 then (let ((res (send-pop-command-get-results pb
730 else ; get all of them
731 (let* ((res (send-pop-command-get-results pb "UIDL" t))
741 (multiple-value-setq (kind mnum next)
742 (get-next-token res next end))
744 (if* (eq :eof kind) then (return))
746 (if* (not (eq :number kind))
748 (po-error :unexpected
749 :format-control "uidl returned illegal message number in ~s"
750 :format-arguments (list res)))
754 (multiple-value-setq (kind mid next)
755 (get-next-token res next end))
757 (if* (eq :number kind)
758 then ; looked like a number to the tokenizer,
759 ; make it a string to be consistent
760 (setq mid (format nil "~d" mid))
761 elseif (not (eq :string kind))
762 then ; didn't find the uid
763 (po-error :unexpected
764 :format-control "uidl returned illegal message id in ~s"
765 :format-arguments (list res)))
767 (push (list mnum mid) coll))
771 (defmethod top-lines ((pb pop-mailbox) message lines)
772 ;; return the header and the given number of top lines of the message
774 (let ((res (send-pop-command-get-results pb
788 (defun check-for-success (mb command count extra comment command-string )
789 (declare (ignore mb count extra))
790 (if* (not (eq command :ok))
791 then (po-error :error-response
792 :format-control "imap ~a failed"
793 :format-arguments (list command-string)
794 :server-string comment)))
800 (defmethod mailbox-list ((mb imap-mailbox) &key (reference "") (pattern ""))
801 ;; return a list of mailbox names with respect to a given
803 (send-command-get-results mb
804 (format nil "list ~s ~s" reference pattern)
805 #'(lambda (mb command count extra comment)
806 (if* (eq command :list)
807 then (push extra res)
808 else (handle-untagged-response
809 mb command count extra
811 #'(lambda (mb command count extra comment)
813 mb command count extra
816 ;; the car of each list is a set of keywords, make that so
818 (setf (car rr) (mapcar #'kwd-intern (car rr))))
826 (defmethod create-mailbox ((mb imap-mailbox) mailbox-name)
827 ;; create a mailbox name of the given name.
828 ;; use mailbox-separator if you want to create a hierarchy
829 (send-command-get-results mb
830 (format nil "create ~s" mailbox-name)
831 #'handle-untagged-response
832 #'(lambda (mb command count extra comment)
834 mb command count extra
839 (defmethod delete-mailbox ((mb imap-mailbox) mailbox-name)
840 ;; create a mailbox name of the given name.
841 ;; use mailbox-separator if you want to create a hierarchy
842 (send-command-get-results mb
843 (format nil "delete ~s" mailbox-name)
844 #'handle-untagged-response
845 #'(lambda (mb command count extra comment)
847 mb command count extra
850 (defmethod rename-mailbox ((mb imap-mailbox) old-mailbox-name new-mailbox-name)
851 ;; create a mailbox name of the given name.
852 ;; use mailbox-separator if you want to create a hierarchy
853 (send-command-get-results mb
854 (format nil "rename ~s ~s"
857 #'handle-untagged-response
858 #'(lambda (mb command count extra comment)
860 mb command count extra
866 (defmethod alter-flags ((mb imap-mailbox)
867 messages &key (flags nil flags-p)
868 add-flags remove-flags
871 ;; change the flags using the store command
875 then (setq cmd "flags" val flags)
877 then (setq cmd "+flags" val add-flags)
879 then (setq cmd "-flags" val remove-flags)
880 else (return-from alter-flags nil))
882 (if* (atom val) then (setq val (list val)))
884 (send-command-get-results mb
885 (format nil "~astore ~a ~a~a ~a"
886 (if* uid then "uid " else "")
887 (message-set-string messages)
895 #'(lambda (mb command count extra comment)
896 (if* (eq command :fetch)
897 then (push (list count
901 else (handle-untagged-response
902 mb command count extra
905 #'(lambda (mb command count extra comment)
907 mb command count extra
912 (defun message-set-string (messages)
913 ;; return a string that describes the messages which may be a
914 ;; single number or a sequence of numbers
917 then (format nil "~a" messages)
918 else (if* (and (consp messages)
919 (eq :seq (car messages)))
920 then (format nil "~a:~a" (cadr messages) (caddr messages))
921 else (let ((str (make-string-output-stream))
923 (dolist (msg messages)
924 (if* precomma then (format str ","))
926 then (format str "~a" msg)
927 elseif (eq :seq (car msg))
929 "~a:~a" (cadr msg) (caddr msg))
930 else (po-error :syntax-error
931 :format-control "bad message list ~s"
932 :format-arguments (list msg)))
934 (get-output-stream-string str)))))
941 (defmethod expunge-mailbox ((mb imap-mailbox))
942 ;; remove messages marked as deleted
944 (send-command-get-results mb
946 #'(lambda (mb command count extra
948 (if* (eq command :expunge)
949 then (push count res)
950 else (handle-untagged-response
951 mb command count extra
953 #'(lambda (mb command count extra comment)
955 mb command count extra
961 (defmethod close-mailbox ((mb imap-mailbox))
962 ;; remove messages marked as deleted
963 (send-command-get-results mb
965 #'handle-untagged-response
967 #'(lambda (mb command count extra comment)
969 mb command count extra
975 (defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination
977 (send-command-get-results mb
978 (format nil "~acopy ~a ~s"
979 (if* uid then "uid " else "")
980 (message-set-string message-list)
982 #'handle-untagged-response
983 #'(lambda (mb command count extra comment)
985 mb command count extra
992 (defmethod search-mailbox ((mb imap-mailbox) search-expression &key uid)
994 (send-command-get-results mb
995 (format nil "~asearch ~a"
996 (if* uid then "uid " else "")
997 (build-search-string search-expression))
998 #'(lambda (mb command count extra comment)
999 (if* (eq command :search)
1000 then (setq res (append res extra))
1001 else (handle-untagged-response
1002 mb command count extra
1004 #'(lambda (mb command count extra comment)
1006 mb command count extra
1011 (defmacro defsearchop (name &rest operands)
1012 (if* (null operands)
1013 then `(setf (get ',name 'imap-search-no-args) t)
1014 else `(setf (get ',name 'imap-search-args) ',operands)))
1017 (defsearchop :answered)
1018 (defsearchop :bcc :str)
1019 (defsearchop :before :date)
1020 (defsearchop :body :str)
1021 (defsearchop :cc :str)
1022 (defsearchop :deleted)
1023 (defsearchop :draft)
1024 (defsearchop :flagged)
1025 (defsearchop :from :str)
1026 (defsearchop :header :str :str)
1027 (defsearchop :keyword :flag)
1028 (defsearchop :larger :number)
1031 (defsearchop :on :date)
1032 (defsearchop :recent)
1034 (defsearchop :sentbefore :date)
1035 (defsearchop :senton :date)
1036 (defsearchop :sentsince :date)
1037 (defsearchop :since :date)
1038 (defsearchop :smaller :number)
1039 (defsearchop :subject :str)
1040 (defsearchop :text :str)
1041 (defsearchop :to :str)
1042 (defsearchop :uid :messageset)
1043 (defsearchop :unanswered)
1044 (defsearchop :undeleted)
1045 (defsearchop :undraft)
1046 (defsearchop :unflagged)
1047 (defsearchop :unkeyword :flag)
1048 (defsearchop :unseen)
1052 (defun build-search-string (search)
1053 ;; take the lisp search form and turn it into a string that can be
1058 else (let ((str (make-string-output-stream)))
1059 (bss-int search str)
1060 (get-output-stream-string str))))
1062 (defun bss-int (search str)
1063 ;;* it turns out that imap (on linux) is very picky about spaces....
1064 ;; any extra whitespace will result in failed searches
1066 (labels ((and-ify (srch str)
1067 (let ((spaceout nil))
1069 (if* spaceout then (format str " "))
1071 (setq spaceout t))))
1073 ; only binary or allowed in imap but we support n-ary
1074 ; or in this interface
1075 (if* (null (cdr srch))
1076 then (bss-int (car srch) str)
1078 then ; over two clauses
1080 (bss-int (car srch) str)
1082 (or-ify (cdr srch) str)
1085 (format str "or (" )
1086 (bss-int (car srch) str)
1088 (bss-int (cadr srch) str)
1091 ;; a sequence of messages
1092 (do* ((xsrch srch (cdr xsrch))
1093 (val (car xsrch) (car xsrch)))
1096 then (format str "~s" val)
1097 elseif (and (consp val)
1099 (eq 3 (length val)))
1100 then (format str "~s:~s" (cadr val) (caddr val))
1101 else (po-error :syntax-error
1102 :format-control "illegal set format ~s"
1103 :format-arguments (list val)))
1104 (if* (cdr xsrch) then (format str ","))))
1105 (arg-process (str args arginfo)
1106 ;; process and print each arg to str
1107 ;; assert (length of args and arginfo are the same)
1108 (do* ((x-args args (cdr x-args))
1109 (val (car x-args) (car x-args))
1110 (x-arginfo arginfo (cdr x-arginfo)))
1112 (ecase (car x-arginfo)
1114 ; print it as a string
1115 (format str " \"~a\"" (car x-args)))
1119 then (setq val (universal-time-to-rfc822-date
1121 elseif (not (stringp val))
1122 then (po-error :syntax-error
1123 :format-control "illegal value for date search ~s"
1124 :format-arguments (list val)))
1125 ;; val is now a string
1126 (format str " ~s" val))
1129 (if* (not (integerp val))
1130 then (po-error :syntax-error
1131 :format-control "illegal value for number in search ~s"
1132 :format-arguments (list val)))
1133 (format str " ~s" val))
1136 ;; should be a symbol in the kwd package
1137 (setq val (string val))
1138 (format str " ~s" val))
1141 then (format str " ~s" val)
1143 then (set-ify val str)
1144 else (po-error :syntax-error
1145 :format-control "illegal message set ~s"
1146 :format-arguments (list val))))
1150 (if* (symbolp search)
1151 then (if* (get search 'imap-search-no-args)
1152 then (format str "~a" (string-upcase
1154 else (po-error :syntax-error
1155 :format-control "illegal search word: ~s"
1156 :format-arguments (list search)))
1157 elseif (consp search)
1158 then (case (car search)
1159 (and (if* (null (cdr search))
1160 then (bss-int :all str)
1161 elseif (null (cddr search))
1162 then (bss-int (cadr search) str)
1163 else (and-ify (cdr search) str)))
1164 (or (if* (null (cdr search))
1165 then (bss-int :all str)
1166 elseif (null (cddr search))
1167 then (bss-int (cadr search) str)
1168 else (or-ify (cdr search) str)))
1169 (not (if* (not (eql (length search) 2))
1170 then (po-error :syntax-error
1171 :format-control "not takes one argument: ~s"
1172 :format-arguments (list search)))
1173 (format str "not (" )
1174 (bss-int (cadr search) str)
1177 (set-ify (list search) str))
1179 (if* (and (symbolp (car search))
1180 (setq arginfo (get (car search)
1181 'imap-search-args)))
1183 (format str "~a" (string-upcase
1184 (string (car search))))
1185 (if* (not (equal (length (cdr search))
1187 then (po-error :syntax-error
1188 :format-control "wrong number of arguments to ~s"
1189 :format-arguments search))
1191 (arg-process str (cdr search) arginfo)
1193 elseif (integerp (car search))
1194 then (set-ify search str)
1195 else (po-error :syntax-error
1196 :format-control "Illegal form ~s in search string"
1197 :format-arguments (list search))))))
1198 elseif (integerp search)
1199 then ; a message number
1200 (format str "~s" search)
1201 else (po-error :syntax-error
1202 :format-control "Illegal form ~s in search string"
1203 :format-arguments (list search)))))
1209 (defun parse-mail-header (text)
1210 ;; given the partial text of a mail message that includes
1211 ;; at least the header part, return an assoc list of
1212 ;; (header . content) items
1213 ;; Note that the header is string with most likely mixed case names
1214 ;; as it's conventional to capitalize header names.
1221 (labels ((next-header-line ()
1222 ;; find the next header line return
1224 ;; :start - beginning of header value, header and
1226 ;; :continue - continuation of previous header line
1230 beginv ; charpos beginning value
1231 beginh ; charpos beginning header
1236 (return-from next-header-line
1238 (loop ; for each character
1243 (setq ch (char text next))
1244 (if* (eq ch #\return)
1245 thenret ; ignore return, (handle following linefeed)
1247 (1 ; no characters seen
1248 (if* (eq ch #\linefeed)
1256 else (setq beginh next)
1259 (2 ; looking for first non blank in value
1260 (if* (eq ch #\linefeed)
1261 then ; empty continuation line, ignore
1264 elseif (not (member ch
1268 then ; begin value part
1271 (3 ; reading the header
1272 (if* (eq ch #\linefeed)
1273 then ; bogus header line, ignore
1277 (subseq text beginh next))
1279 (4 ; looking for the end of the value
1280 (if* (eq ch #\linefeed)
1291 else :continue))))))
1296 (loop ; for each header line
1298 (if* (eq :eof (setq kind (next-header-line)))
1301 (:start (push (cons header value) headers))
1304 then ; append to previous one
1305 (setf (cdr (car headers))
1306 (concatenate 'string (cdr (car headers))
1310 (subseq text next end))))
1313 (defun make-envelope-from-text (text)
1314 ;; given at least the headers part of a message return
1315 ;; an envelope structure containing the contents
1316 ;; This is useful for parsing the headers of things returned by
1319 (let ((headers (parse-mail-header text)))
1322 :date (cdr (assoc "date" headers :test #'equalp))
1323 :subject (cdr (assoc "subject" headers :test #'equalp))
1324 :from (cdr (assoc "from" headers :test #'equalp))
1325 :sender (cdr (assoc "sender" headers :test #'equalp))
1326 :reply-to (cdr (assoc "reply-to" headers :test #'equalp))
1327 :to (cdr (assoc "to" headers :test #'equalp))
1328 :cc (cdr (assoc "cc" headers :test #'equalp))
1329 :bcc (cdr (assoc "bcc" headers :test #'equalp))
1330 :in-reply-to (cdr (assoc "in-reply-to" headers :test #'equalp))
1331 :message-id (cdr (assoc "message-id" headers :test #'equalp))
1343 (defmethod get-and-parse-from-imap-server ((mb imap-mailbox))
1344 ;; read the next line and parse it
1347 (multiple-value-bind (line count)
1348 (get-line-from-server mb)
1350 then (format t "from server: ")
1351 (dotimes (i count)(write-char (schar line i)))
1355 (parse-imap-response line count)
1360 (defmethod get-and-parse-from-pop-server ((mb pop-mailbox))
1361 ;; read the next line from the pop server
1365 ;; a list of rest of the tokens on the line
1366 ;; the whole line after the +ok or -err
1368 (multiple-value-bind (line count)
1369 (get-line-from-server mb)
1372 then (format t "from server: " count)
1373 (dotimes (i count)(write-char (schar line i)))
1376 (parse-pop-response line count)))
1380 ;; Parse and return the data from each line
1382 ;; tag -- either a string or the symbol :untagged
1383 ;; command -- a keyword symbol naming the command, like :ok
1384 ;; count -- a number which preceeded the command, or nil if
1385 ;; there wasn't a command
1386 ;; bracketted - a list of objects found in []'s after the command
1387 ;; or in ()'s after the command or sometimes just
1388 ;; out in the open after the command (like the search)
1389 ;; comment -- the whole of the part after the command
1391 (defun parse-imap-response (line end)
1392 (let (kind value next
1393 tag count command extra-data
1397 (multiple-value-setq (kind value next)
1398 (get-next-token line 0 end))
1401 (:string (setq tag (if* (equal value "*")
1404 (t (po-error :unexpected
1405 :format-control "Illegal tag on response: ~s"
1406 :format-arguments (list (subseq line 0 count))
1407 :server-string (subseq line 0 end)
1411 (multiple-value-setq (kind value next)
1412 (get-next-token line next end))
1416 (:number (setq count value)
1417 (multiple-value-setq (kind value next)
1418 (get-next-token line next end))
1420 (:string (setq command (kwd-intern value)))
1421 (t (po-error :unexpected
1422 :format-control "Illegal command on response: ~s"
1423 :format-arguments (list (subseq line 0 count))
1424 :server-string (subseq line 0 end)))))
1426 (setq comment (subseq line next end))
1428 ;; now the part after the command... this gets tricky
1430 (multiple-value-setq (kind value next)
1431 (get-next-token line next end))
1434 ((:lbracket :lparen)
1435 (multiple-value-setq (kind value next)
1436 (get-next-sexpr line (1- next) end))
1438 (:sexpr (push value extra-data))
1439 (t (po-error :syntax-error :format-control "bad sexpr form"))))
1441 ((:number :string :nil) (push value extra-data))
1442 (t ; should never happen
1445 (if* (not (member command '(:list :search) :test #'eq))
1446 then ; only one item returned
1447 (setq extra-data (car extra-data))
1450 (if* (member command '(:list :search) :test #'eq)
1451 then (setq extra-data (nreverse extra-data)))
1454 (values tag command count extra-data comment)))
1458 (defun get-next-sexpr (line start end)
1459 ;; read a whole s-expression
1461 ;; kind -- :sexpr or :rparen or :rbracket
1462 ;; value - the sexpr value
1463 ;; next - next charpos to scan
1465 (let ( kind value next)
1466 (multiple-value-setq (kind value next) (get-next-token line start end))
1469 ((:string :number :nil)
1470 (values :sexpr value next))
1471 (:eof (po-error :syntax-error
1472 :format-control "eof inside sexpr"))
1473 ((:lbracket :lparen)
1476 (multiple-value-setq (kind value next)
1477 (get-next-sexpr line next end))
1479 (:sexpr (push value res))
1480 ((:rparen :rbracket)
1481 (return (values :sexpr (nreverse res) next)))
1482 (t (po-error :syntax-error
1483 :format-control "bad sexpression"))))))
1484 ((:rbracket :rparen)
1485 (values kind nil next))
1486 (t (po-error :syntax-error
1487 :format-control "bad sexpression")))))
1490 (defun parse-pop-response (line end)
1493 ;; a list of rest of the tokens on the line, the tokens
1494 ;; being either strings or integers
1495 ;; the whole line after the +ok or -err
1497 (let (res lineres result)
1498 (multiple-value-bind (kind value next)
1499 (get-next-token line 0 end)
1502 (:string (setq result (if* (equal "+OK" value)
1505 (t (po-error :unexpected
1506 :format-control "bad response from server"
1507 :server-string (subseq line 0 end))))
1509 (setq lineres (subseq line next end))
1512 (multiple-value-setq (kind value next)
1513 (get-next-token line next end))
1517 ((:string :number) (push value res))))
1519 (values result (nreverse res) lineres))))
1530 (defparameter *char-to-kind*
1531 (let ((arr (make-array 256 :initial-element nil)))
1533 (do ((i #.(char-code #\0) (1+ i)))
1534 ((> i #.(char-code #\9)))
1535 (setf (aref arr i) :number))
1537 (setf (aref arr #.(char-code #\space)) :space)
1538 (setf (aref arr #.(char-code #\tab)) :space)
1539 (setf (aref arr #.(char-code #\return)) :space)
1540 (setf (aref arr #.(char-code #\linefeed)) :space)
1542 (setf (aref arr #.(char-code #\[)) :lbracket)
1543 (setf (aref arr #.(char-code #\])) :rbracket)
1544 (setf (aref arr #.(char-code #\()) :lparen)
1545 (setf (aref arr #.(char-code #\))) :rparen)
1546 (setf (aref arr #.(char-code #\")) :dquote)
1548 (setf (aref arr #.(char-code #\^b)) :big-string) ; our own invention
1553 (defun get-next-token (line start end)
1554 ;; scan past whitespace for the next token
1555 ;; return three values:
1556 ;; kind: :string , :number, :eof, :lbracket, :rbracket,
1558 ;; value: the value, either a string or number or nil
1559 ;; next: the character pos to start scanning for the next token
1561 (let (ch chkind colstart (count 0) (state :looking)
1562 collector right-bracket-is-normal)
1564 ; pick up the next character
1566 then (if* (eq state :looking)
1567 then (return (values :eof nil start))
1568 else (setq ch #\space))
1569 else (setq ch (schar line start)))
1571 (setq chkind (aref *char-to-kind* (char-code ch)))
1577 (:number (setq state :number)
1578 (setq colstart start)
1579 (setq count (- (char-code ch) #.(char-code #\0))))
1580 ((:lbracket :lparen :rbracket :rparen)
1581 (return (values chkind nil (1+ start))))
1583 (setq collector (make-array 10
1584 :element-type 'character
1587 (setq state :qstring))
1589 (setq colstart (1+ start))
1590 (setq state :big-string))
1591 (t (setq colstart start)
1592 (setq state :literal))))
1595 ((:space :lbracket :lparen :rbracket :rparen
1596 :dquote) ; end of number
1597 (return (values :number count start)))
1598 (:number ; more number
1599 (setq count (+ (* count 10)
1600 (- (char-code ch) #.(char-code #\0)))))
1601 (t ; turn into an literal
1602 (setq state :literal))))
1605 ((:space :rbracket :lparen :rparen :dquote) ; end of literal
1606 (if* (and (eq chkind :rbracket)
1607 right-bracket-is-normal)
1608 then nil ; don't stop now
1609 else (let ((seq (subseq line colstart start)))
1610 (if* (equal "NIL" seq)
1611 then (return (values :nil
1614 else (return (values :string
1617 (t (if* (eq chkind :lbracket)
1618 then ; imbedded left bracket so right bracket isn't
1620 (setq right-bracket-is-normal t))
1624 ; (format t "start is ~s kind is ~s~%" start chkind)
1628 (return (values :string collector (1+ start))))
1630 then ; escaping the next character
1633 then (po-error :unexpected
1634 :format-control "eof in string returned"))
1635 (setq ch (schar line start)))
1636 (vector-push-extend ch collector)
1639 then ; we overran the end of the input
1640 (po-error :unexpected
1641 :format-control "eof in string returned")))))
1643 ;; super string... just a block of data
1644 ; (format t "start is ~s kind is ~s~%" start chkind)
1648 (return (values :string
1649 (subseq line colstart start)
1660 ; this used to be exported from the excl package
1661 #+(and allegro (version>= 6 0))
1662 (defvar *keyword-package* (find-package :keyword))
1665 (defun kwd-intern (string)
1666 ;; convert the string to the current preferred case
1669 #-allegro acl-compat.excl::*current-case-mode*
1670 #+allegro excl::*current-case-mode*
1671 ((:case-sensitive-lower
1672 :case-insensitive-lower) (string-downcase string))
1673 (t (string-upcase string)))
1689 ;; low level i/o to server
1691 (defun get-line-from-server (mailbox)
1692 ;; Return two values: a buffer and a character count.
1693 ;; The character count includes up to but excluding the cr lf that
1694 ;; was read from the socket.
1696 (let* ((buff (get-line-buffer 0))
1699 (p (post-office-socket mailbox))
1705 (flet ((grow-buffer (size)
1706 (let ((newbuff (get-line-buffer size)))
1708 (setf (schar newbuff j) (schar buff j)))
1709 (free-line-buffer buff)
1711 (setq len (length buff)))))
1713 ;; increase the buffer to at least size
1714 ;; this is somewhat complex to ensure that we aren't doing
1715 ;; buffer allocation within the with-timeout form, since
1716 ;; that could trigger a gc which could then cause the
1717 ;; with-timeout form to expire.
1721 then ; we should now read in this may bytes and
1722 ; append it to this buffer
1723 (multiple-value-bind (ans this-count)
1724 (get-block-of-data-from-server mailbox whole-count)
1725 ; now put this data in the current buffer
1726 (if* (> (+ i whole-count 5) len)
1727 then ; grow the initial buffer
1728 (grow-buffer (+ i whole-count 100)))
1730 (dotimes (ind this-count)
1731 (setf (schar buff i) (schar ans ind))
1733 (setf (schar buff i) #\^b) ; end of inset string
1735 (free-line-buffer ans)
1736 (setq whole-count nil)
1739 then ; we're growing the buffer holding the line data
1740 (grow-buffer (+ len 200))
1741 (setf (schar buff i) ch)
1746 (with-timeout ((timeout mailbox)
1748 :format-control "imap server failed to respond"))
1749 ;; read up to lf (lf most likely preceeded by cr)
1751 (setq ch (read-char p))
1752 (if* (eq #\linefeed ch)
1753 then ; end of line. Don't save the return
1755 (eq (schar buff (1- i)) #\return))
1756 then ; remove #\return, replace with newline
1758 (setf (schar buff i) #\newline)
1760 ;; must check for an extended return value which
1761 ;; is indicated by a {nnn} at the end of the line
1764 (if* (and (>= i 0) (eq (schar buff ind) #\}))
1765 then (let ((count 0)
1770 then ; no of the form {nnn}
1771 (return-from count-check))
1772 (setf ch (schar buff ind))
1774 then ; must now read that many bytes
1775 (setf (schar buff ind) #\^b)
1776 (setq whole-count count)
1778 (return-from timeout)
1779 elseif (<= #.(char-code #\0)
1787 #.(char-code #\0)))))
1788 (setq mult (* 10 mult))
1789 else ; invalid form, get out
1790 (return-from count-check)))))))
1793 (return-from get-line-from-server
1795 else ; save character
1797 then ; need bigger buffer
1799 (setf (schar buff i) ch)
1802 ;; most likely error is that the server went away
1803 (ignore-errors (close p))
1804 (po-error :server-shutdown-connection
1805 :format-control "condition signalled: ~a~%most likely server shut down the connection."
1806 :format-arguments (list con)))
1810 (defun get-block-of-data-from-server (mb count &key save-returns)
1811 ;; read count bytes from the server returning it in a line buffer object
1812 ;; return as a second value the number of characters saved
1813 ;; (we drop #\return's so that lines are sepisarated by a #\newline
1814 ;; like lisp likes).
1816 (let ((buff (get-line-buffer count))
1817 (p (post-office-socket mb))
1819 (with-timeout ((timeout mb)
1821 :format-control "imap server timed out"))
1824 (if* (eq #\return (setf (schar buff ind) (read-char p)))
1825 then (if* save-returns then (incf ind)) ; drop #\returns
1829 (values buff ind))))
1832 ;;-- reusable line buffers
1834 (defvar *line-buffers* nil)
1836 (defun get-line-buffer (size)
1837 ;; get a buffer of at least size bytes
1838 (setq size (min size (1- array-total-size-limit)))
1840 (dolist (buff *line-buffers* (make-string size))
1841 (if* (>= (length buff) size)
1843 (setq *line-buffers* (delete buff *line-buffers*))
1847 (defun free-line-buffer (buff)
1849 (push buff *line-buffers*)))
1851 (defun init-line-buffer (new old)
1852 ;; copy old into new
1853 (declare (optimize (speed 3)))
1854 (dotimes (i (length old))
1855 (declare (fixnum i))
1856 (setf (schar new i) (schar old i))))
1865 (defun universal-time-to-rfc822-date (ut)
1866 ;; convert a lisp universal time to rfc 822 date
1868 (multiple-value-bind
1869 (sec min hour date month year day-of-week dsp time-zone)
1870 (decode-universal-time ut 0)
1871 (declare (ignore time-zone sec min hour day-of-week dsp time-zone))
1872 (format nil "~d-~a-~d"
1875 '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
1876 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")