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.cl,v 1.1 2002/10/09 14:26:11 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 (defpackage :net.post-office
56 #:envelope-in-reply-to
63 #:*imap-version-number*
64 #:make-envelope-from-text
65 #:mailbox-flags ; accessor
66 #:mailbox-permanent-flags ; acc
69 #:mailbox-list-separator
71 #:mailbox-message-count ; accessor
72 #:mailbox-recent-messages ; ac
73 #:mailbox-separator ; accessor
75 #:make-imap-connection
79 #:top-lines ; pop only
80 #:unique-id ; pop only
83 #:po-condition-identifier
84 #:po-condition-server-string
94 (in-package :net.post-office)
98 (defparameter *imap-version-number* '(:major 1 :minor 8)) ; major.minor
101 ;; have the list of tags selected done on a per connection basis to
102 ;; eliminate any possible multithreading problems
106 (defvar *debug-imap* nil)
112 (defclass post-office ()
113 ((socket :initarg :socket
114 :accessor post-office-socket)
117 :accessor post-office-host
120 :accessor post-office-user
123 (state :accessor post-office-state
125 :initform :unconnected)
128 ;; time to wait for network activity for actions that should
129 ;; happen very quickly when things are operating normally
135 (defclass imap-mailbox (post-office)
136 ((mailbox-name ; currently selected mailbox
137 :accessor mailbox-name
141 ;; string that separates mailbox names in the hierarchy
142 :accessor mailbox-separator
145 ;;; these slots hold information about the currently selected mailbox:
147 (message-count ; how many in the mailbox
148 :accessor mailbox-message-count
151 (recent-messages ; how many messages since we last checked
152 :accessor mailbox-recent-messages
155 (uidvalidity ; used to denote messages uniquely
156 :accessor mailbox-uidvalidity
160 :accessor mailbox-uidnext ;; predicted next uid
163 (flags ; list of flags that can be stored in a message
164 :accessor mailbox-flags
167 (permanent-flags ; list of flags that be stored permanently
168 :accessor mailbox-permanent-flags
171 (first-unseen ; number of the first unseen message
172 :accessor first-unseen
175 ;;; end list of values for the currently selected mailbox
180 (defclass pop-mailbox (post-office)
181 ((message-count ; how many in the mailbox
182 :accessor mailbox-message-count
187 (defstruct (mailbox-list (:type list))
188 ;; a list of these are returned by mailbox-list
195 (defstruct (envelope (:type list))
196 ;; returned by fetch-letter as the value of the envelope property
209 (defstruct (address (:type list))
210 name ;; often the person's full name
212 mailbox ;; the login name
213 host ;; the name of the machine
218 ;--------------------------------
221 ; We define a set of conditions that are signalled due to events
222 ; in the imap interface.
223 ; Each condition has an indentifier which is a keyword. That can
224 ; be used in the handling code to identify the class of error.
225 ; All our conditions are po-condition or po-error (which is a subclass of
228 ; A condition will have a server-string value if it as initiated by
229 ; something returned by the server.
230 ; A condition will have a format-control value if we want to display
231 ; something we generated in response to
235 ;; identifiers used in conditions/errors
238 ; the server responded with 'no' followed by an explanation.
239 ; this mean that something unusual happend and doesn't necessarily
240 ; mean that the command has completely failed (but it might).
242 ; :unknown-ok condition
243 ; the server responded with an 'ok' followed by something
244 ; we don't recognize. It's probably safe to ignore this.
246 ; :unknown-untagged condition
247 ; the server responded with some untagged command we don't
248 ; recognize. it's probaby ok to ignore this.
250 ; :error-response error
251 ; the command failed.
253 ; :syntax-error error
254 ; the data passed to a function in this interface was malformed
257 ; the server responded an unexpected way.
259 ; :server-shutdown-connection error
260 ; the server has shut down the connection, don't attempt to
261 ; send any more commands to this connection, or even close it.
264 ; server failed to respond within the timeout period
266 ; :response-too-large error
267 ; contents of a response is too large to store in a Lisp array.
271 (define-condition po-condition ()
272 ;; used to notify user of things that shouldn't necessarily stop
275 ;; keyword identifying the error (or :unknown)
276 :reader po-condition-identifier
281 ;; message from the imap server
282 :reader po-condition-server-string
284 :initarg :server-string
288 (with-slots (identifier server-string) con
289 ;; a condition either has a server-string or it has a
290 ;; format-control string
291 (format stream "Post Office condition: ~s~%" identifier)
292 (if* (and (slot-boundp con 'excl::format-control)
293 (excl::simple-condition-format-control con))
294 then (apply #'format stream
295 (excl::simple-condition-format-control con)
296 (excl::simple-condition-format-arguments con)))
299 "~&Message from server: ~s"
300 (string-left-trim " " server-string)))))))
304 (define-condition po-error (po-condition error)
305 ;; used to denote things that should stop program flow
310 ;; aignalling the conditions
312 (defun po-condition (identifier &key server-string format-control
314 (signal (make-instance 'po-condition
315 :identifier identifier
316 :server-string server-string
317 :format-control format-control
318 :format-arguments format-arguments
321 (defun po-error (identifier &key server-string
322 format-control format-arguments)
323 (error (make-instance 'po-error
324 :identifier identifier
325 :server-string server-string
326 :format-control format-control
327 :format-arguments format-arguments)))
331 ;----------------------------------------------
338 (defparameter *imap-tags* '("t01" "t02" "t03" "t04" "t05" "t06" "t07"))
339 (defvar *cur-imap-tags* nil)
342 (let ((str (make-string 2)))
343 (setf (aref str 0) #\return)
344 (setf (aref str 1) #\linefeed)
347 (defun make-imap-connection (host &key (port 143)
351 (let* ((sock (socket:make-socket :remote-host host
353 (imap (make-instance 'imap-mailbox
357 :state :unauthorized)))
359 (multiple-value-bind (tag cmd count extra comment)
360 (get-and-parse-from-imap-server imap)
361 (declare (ignore cmd count extra))
362 (if* (not (eq :untagged tag))
363 then (po-error :error-response
364 :server-string comment)))
367 (send-command-get-results imap
368 (format nil "login ~a ~a" user password)
369 #'handle-untagged-response
370 #'(lambda (mb command count extra comment)
371 (check-for-success mb command count extra
375 ; find the separator character
376 (let ((res (mailbox-list imap)))
378 (let ((sep (cadr (car res))))
380 then (setf (mailbox-separator imap) sep))))
387 (defmethod close-connection ((mb imap-mailbox))
389 (let ((sock (post-office-socket mb)))
392 (send-command-get-results
395 ; don't want to get confused by untagged
396 ; bye command, which is expected here
397 #'(lambda (mb command count extra)
398 (declare (ignore mb command count extra))
400 #'(lambda (mb command count extra comment)
401 (check-for-success mb command count extra
404 (setf (post-office-socket mb) nil)
405 (if* sock then (ignore-errors (close sock)))
409 (defmethod close-connection ((pb pop-mailbox))
410 (let ((sock (post-office-socket pb)))
413 (send-pop-command-get-results
416 (setf (post-office-socket pb) nil)
417 (if* sock then (ignore-errors (close sock)))
422 (defun make-pop-connection (host &key (port 110)
426 (let* ((sock (socket:make-socket :remote-host host
428 (pop (make-instance 'pop-mailbox
432 :state :unauthorized)))
434 (multiple-value-bind (result)
435 (get-and-parse-from-pop-server pop)
436 (if* (not (eq :ok result))
437 then (po-error :error-response
439 "unexpected line from server after connect")))
442 (send-pop-command-get-results pop (format nil "user ~a" user))
443 (send-pop-command-get-results pop (format nil "pass ~a" password))
445 (let ((res (send-pop-command-get-results pop "stat")))
446 (setf (mailbox-message-count pop) (car res)))
453 (defmethod send-command-get-results ((mb imap-mailbox)
454 command untagged-handler tagged-handler)
455 ;; send a command and retrieve results until we get the tagged
456 ;; response for the command we sent
458 (let ((tag (get-next-tag)))
459 (format (post-office-socket mb)
460 "~a ~a~a" tag command *crlf*)
461 (force-output (post-office-socket mb))
465 "~a ~a~a" tag command *crlf*)
468 (multiple-value-bind (got-tag cmd count extra comment)
469 (get-and-parse-from-imap-server mb)
470 (if* (eq got-tag :untagged)
471 then (funcall untagged-handler mb cmd count extra comment)
472 elseif (equal tag got-tag)
473 then (funcall tagged-handler mb cmd count extra comment)
475 else (po-error :error-response
476 :format-control "received tag ~s out of order"
477 :format-arguments (list got-tag)
478 :server-string comment))))))
481 (defun get-next-tag ()
482 (let ((tag (pop *cur-imap-tags*)))
485 else (setq *cur-imap-tags* *imap-tags*)
486 (pop *cur-imap-tags*))))
488 (defun handle-untagged-response (mb command count extra comment)
489 ;; default function to handle untagged responses, which are
490 ;; really just returning general state information about
493 (:exists (setf (mailbox-message-count mb) count))
494 (:recent (setf (mailbox-recent-messages mb) count))
495 (:flags (setf (mailbox-flags mb) (mapcar #'kwd-intern extra)))
496 (:bye ; occurs when connection times out or mailbox lock is stolen
497 (ignore-errors (close (post-office-socket mb)))
498 (po-error :server-shutdown-connection
499 :server-string "server shut down the connection"))
500 (:no ; used when grabbing a lock from another process
501 (po-condition :problem :server-string comment))
502 (:ok ; a whole variety of things
504 then (if* (equalp (car extra) "unseen")
505 then (setf (first-unseen mb) (cadr extra))
506 elseif (equalp (car extra) "uidvalidity")
507 then (setf (mailbox-uidvalidity mb) (cadr extra))
508 elseif (equalp (car extra) "uidnext")
509 then (setf (mailbox-uidnext mb) (cadr extra))
510 elseif (equalp (car extra) "permanentflags")
511 then (setf (mailbox-permanent-flags mb)
512 (mapcar #'kwd-intern (cadr extra)))
513 else (po-condition :unknown-ok :server-string comment))))
514 (t (po-condition :unknown-untagged :server-string comment)))
520 (defun send-pop-command-get-results (pop command &optional extrap)
521 ;; send the given command to the pop server
522 ;; if extrap is true and if the response is +ok, then data
523 ;; will follow the command (up to and excluding the first line consisting
526 ;; if the pop server returns an error code we signal a lisp error.
529 ;; extrap is nil -- return the list of tokens on the line after +ok
530 ;; extrap is true -- return the extra object (a big string)
532 (format (post-office-socket pop) "~a~a" command *crlf*)
533 (force-output (post-office-socket pop))
536 then (format t "~a~a" command *crlf*)
539 (multiple-value-bind (result parsed line)
540 (get-and-parse-from-pop-server pop)
541 (if* (not (eq result :ok))
542 then (po-error :error-response
543 :server-string line))
546 then ;; get the rest of the data
547 ;; many but not all pop servers return the size of the data
548 ;; after the +ok, so we use that to initially size the
550 (let ((buf (get-line-buffer (+ (if* (fixnump (car parsed))
552 else 2048 ; reasonable size
558 ; 2 - seen dot at beginning of line
559 ; 3 - seen regular char on line
561 (sock (post-office-socket pop)))
562 (flet ((add-to-buffer (ch)
563 (if* (>= pos (length buf))
565 (if* (>= (length buf)
566 (1- array-total-size-limit))
567 then ; can't grow it any further
571 "response from mail server is too large to hold in a lisp array"))
572 (let ((new-buf (get-line-buffer
573 (* (length buf) 2))))
574 (init-line-buffer new-buf buf)
575 (free-line-buffer buf)
577 (setf (schar buf pos) ch)
580 (let ((ch (read-char sock nil nil)))
582 then (po-error :unexpected
583 :format-control "premature end of file from server"))
584 (if* (eq ch #\return)
589 elseif (eq ch #\linefeed)
590 then (add-to-buffer ch)
592 else (add-to-buffer ch)
595 (if* (eq ch #\linefeed)
596 then ; end of message
598 else (add-to-buffer ch)
602 (if* (eq ch #\linefeed)
603 then (setq state 1))))))))
604 (prog1 (subseq buf 0 pos)
605 (free-line-buffer buf)))
611 (defun convert-flags-plist (plist)
612 ;; scan the plist looking for "flags" indicators and
613 ;; turn value into a list of symbols rather than strings
614 (do ((xx plist (cddr xx)))
616 (if* (equalp "flags" (car xx))
617 then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))))))
620 (defmethod select-mailbox ((mb imap-mailbox) name)
621 ;; select the given mailbox
622 (send-command-get-results mb
623 (format nil "select ~a" name)
624 #'handle-untagged-response
625 #'(lambda (mb command count extra comment)
626 (declare (ignore mb count extra))
627 (if* (not (eq command :ok))
631 "imap mailbox select failed"
632 :server-string comment))))
633 (setf (mailbox-name mb) name)
638 (defmethod fetch-letter ((mb imap-mailbox) number &key uid)
639 ;; return the whole letter
640 (fetch-field number "body[]"
641 (fetch-parts mb number "body[]" :uid uid)
645 (defmethod fetch-letter ((pb pop-mailbox) number &key uid)
646 (declare (ignore uid))
647 (send-pop-command-get-results pb
648 (format nil "RETR ~d" number)
652 (defmethod fetch-parts ((mb imap-mailbox) number parts &key uid)
654 (send-command-get-results
656 (format nil "~afetch ~a ~a"
657 (if* uid then "uid " else "")
658 (message-set-string number)
661 #'(lambda (mb command count extra comment)
662 (if* (eq command :fetch)
663 then (push (list count (internalize-flags extra)) res)
664 else (handle-untagged-response
665 mb command count extra comment)))
666 #'(lambda (mb command count extra comment)
667 (declare (ignore mb count extra))
668 (if* (not (eq command :ok))
669 then (po-error :problem
670 :format-control "imap mailbox fetch failed"
671 :server-string comment))))
675 (defun fetch-field (letter-number field-name info &key uid)
676 ;; given the information from a fetch-letter, return the
677 ;; particular field for the particular letter
679 ;; info is as returned by fetch
680 ;; field-name is a string, case doesn't matter.
683 ;; item is (messagenumber plist-info)
684 ;; the same messagenumber may appear in multiple items
687 then ; uid appears as a property in the value, not
688 ; as the top level message sequence number
689 (do ((xx (cadr item) (cddr xx)))
691 (if* (equalp "uid" (car xx))
692 then (if* (eql letter-number (cadr xx))
693 then (return (setq use-this t))
695 else ; just a message sequence number
696 (setq use-this (eql letter-number (car item))))
699 then (do ((xx (cadr item) (cddr xx)))
701 (if* (equalp field-name (car xx))
702 then (return-from fetch-field (cadr xx))))))))
706 (defun internalize-flags (stuff)
707 ;; given a plist like object, look for items labelled "flags" and
708 ;; convert the contents to internal flags objects
709 (do ((xx stuff (cddr xx)))
711 (if* (equalp (car xx) "flags")
712 then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx)))
720 (defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid)
721 ;; delete all the mesasges and do the expunge to make
722 ;; it permanent if expunge is true
723 (alter-flags mb messages :add-flags :\\deleted :uid uid)
724 (if* expunge then (expunge-mailbox mb)))
726 (defmethod delete-letter ((pb pop-mailbox) messages &key (expunge nil) uid)
727 ;; delete all the messages. We can't expunge without quitting so
729 (declare (ignore expunge uid))
731 (if* (or (numberp messages)
732 (and (consp messages) (eq :seq (car messages))))
733 then (setq messages (list messages)))
735 (if* (not (consp messages))
736 then (po-error :syntax-error
737 :format-control "expect a mesage number or list of messages, not ~s"
738 :format-arguments (list messages)))
740 (dolist (message messages)
741 (if* (numberp message)
742 then (send-pop-command-get-results pb
743 (format nil "DELE ~d" message))
744 elseif (and (consp message) (eq :seq (car message)))
745 then (do ((start (cadr message) (1+ start))
746 (end (caddr message)))
748 (send-pop-command-get-results pb
749 (format nil "DELE ~d" start)))
750 else (po-error :syntax-error
751 :format-control "bad message number ~s"
752 :format-arguments (list message)))))
758 (defmethod noop ((mb imap-mailbox))
759 ;; just poke the server... keeping it awake and checking for
761 (send-command-get-results mb
763 #'handle-untagged-response
764 #'(lambda (mb command count extra comment)
766 mb command count extra
771 (defmethod noop ((pb pop-mailbox))
772 ;; send the stat command instead so we can update the message count
773 (let ((res (send-pop-command-get-results pb "stat")))
774 (setf (mailbox-message-count pb) (car res)))
778 (defmethod unique-id ((pb pop-mailbox) &optional message)
779 ;; if message is given, return the unique id of that
781 ;; if message is not given then return a list of lists:
782 ;; (message unique-id)
783 ;; for all messages not marked as deleted
786 then (let ((res (send-pop-command-get-results pb
791 else ; get all of them
792 (let* ((res (send-pop-command-get-results pb "UIDL" t))
802 (multiple-value-setq (kind mnum next)
803 (get-next-token res next end))
805 (if* (eq :eof kind) then (return))
807 (if* (not (eq :number kind))
809 (po-error :unexpected
810 :format-control "uidl returned illegal message number in ~s"
811 :format-arguments (list res)))
815 (multiple-value-setq (kind mid next)
816 (get-next-token res next end))
818 (if* (eq :number kind)
819 then ; looked like a number to the tokenizer,
820 ; make it a string to be consistent
821 (setq mid (format nil "~d" mid))
822 elseif (not (eq :string kind))
823 then ; didn't find the uid
824 (po-error :unexpected
825 :format-control "uidl returned illegal message id in ~s"
826 :format-arguments (list res)))
828 (push (list mnum mid) coll))
832 (defmethod top-lines ((pb pop-mailbox) message lines)
833 ;; return the header and the given number of top lines of the message
835 (let ((res (send-pop-command-get-results pb
849 (defun check-for-success (mb command count extra comment command-string )
850 (declare (ignore mb count extra))
851 (if* (not (eq command :ok))
852 then (po-error :error-response
853 :format-control "imap ~a failed"
854 :format-arguments (list command-string)
855 :server-string comment)))
861 (defmethod mailbox-list ((mb imap-mailbox) &key (reference "") (pattern ""))
862 ;; return a list of mailbox names with respect to a given
864 (send-command-get-results mb
865 (format nil "list ~s ~s" reference pattern)
866 #'(lambda (mb command count extra comment)
867 (if* (eq command :list)
868 then (push extra res)
869 else (handle-untagged-response
870 mb command count extra
872 #'(lambda (mb command count extra comment)
874 mb command count extra
877 ;; the car of each list is a set of keywords, make that so
879 (setf (car rr) (mapcar #'kwd-intern (car rr))))
887 (defmethod create-mailbox ((mb imap-mailbox) mailbox-name)
888 ;; create a mailbox name of the given name.
889 ;; use mailbox-separator if you want to create a hierarchy
890 (send-command-get-results mb
891 (format nil "create ~s" mailbox-name)
892 #'handle-untagged-response
893 #'(lambda (mb command count extra comment)
895 mb command count extra
900 (defmethod delete-mailbox ((mb imap-mailbox) mailbox-name)
901 ;; create a mailbox name of the given name.
902 ;; use mailbox-separator if you want to create a hierarchy
903 (send-command-get-results mb
904 (format nil "delete ~s" mailbox-name)
905 #'handle-untagged-response
906 #'(lambda (mb command count extra comment)
908 mb command count extra
911 (defmethod rename-mailbox ((mb imap-mailbox) old-mailbox-name new-mailbox-name)
912 ;; create a mailbox name of the given name.
913 ;; use mailbox-separator if you want to create a hierarchy
914 (send-command-get-results mb
915 (format nil "rename ~s ~s"
918 #'handle-untagged-response
919 #'(lambda (mb command count extra comment)
921 mb command count extra
927 (defmethod alter-flags ((mb imap-mailbox)
928 messages &key (flags nil flags-p)
929 add-flags remove-flags
932 ;; change the flags using the store command
936 then (setq cmd "flags" val flags)
938 then (setq cmd "+flags" val add-flags)
940 then (setq cmd "-flags" val remove-flags)
941 else (return-from alter-flags nil))
943 (if* (atom val) then (setq val (list val)))
945 (send-command-get-results mb
946 (format nil "~astore ~a ~a~a ~a"
947 (if* uid then "uid " else "")
948 (message-set-string messages)
956 #'(lambda (mb command count extra comment)
957 (if* (eq command :fetch)
958 then (push (list count
962 else (handle-untagged-response
963 mb command count extra
966 #'(lambda (mb command count extra comment)
968 mb command count extra
973 (defun message-set-string (messages)
974 ;; return a string that describes the messages which may be a
975 ;; single number or a sequence of numbers
978 then (format nil "~a" messages)
979 else (if* (and (consp messages)
980 (eq :seq (car messages)))
981 then (format nil "~a:~a" (cadr messages) (caddr messages))
982 else (let ((str (make-string-output-stream))
984 (dolist (msg messages)
985 (if* precomma then (format str ","))
987 then (format str "~a" msg)
988 elseif (eq :seq (car msg))
990 "~a:~a" (cadr msg) (caddr msg))
991 else (po-error :syntax-error
992 :format-control "bad message list ~s"
993 :format-arguments (list msg)))
995 (get-output-stream-string str)))))
1002 (defmethod expunge-mailbox ((mb imap-mailbox))
1003 ;; remove messages marked as deleted
1005 (send-command-get-results mb
1007 #'(lambda (mb command count extra
1009 (if* (eq command :expunge)
1010 then (push count res)
1011 else (handle-untagged-response
1012 mb command count extra
1014 #'(lambda (mb command count extra comment)
1016 mb command count extra
1017 comment "expunge")))
1022 (defmethod close-mailbox ((mb imap-mailbox))
1023 ;; remove messages marked as deleted
1024 (send-command-get-results mb
1026 #'handle-untagged-response
1028 #'(lambda (mb command count extra comment)
1030 mb command count extra
1036 (defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination
1038 (send-command-get-results mb
1039 (format nil "~acopy ~a ~s"
1040 (if* uid then "uid " else "")
1041 (message-set-string message-list)
1043 #'handle-untagged-response
1044 #'(lambda (mb command count extra comment)
1046 mb command count extra
1053 (defmethod search-mailbox ((mb imap-mailbox) search-expression &key uid)
1055 (send-command-get-results mb
1056 (format nil "~asearch ~a"
1057 (if* uid then "uid " else "")
1058 (build-search-string search-expression))
1059 #'(lambda (mb command count extra comment)
1060 (if* (eq command :search)
1061 then (setq res (append res extra))
1062 else (handle-untagged-response
1063 mb command count extra
1065 #'(lambda (mb command count extra comment)
1067 mb command count extra
1072 (defmacro defsearchop (name &rest operands)
1073 (if* (null operands)
1074 then `(setf (get ',name 'imap-search-no-args) t)
1075 else `(setf (get ',name 'imap-search-args) ',operands)))
1078 (defsearchop :answered)
1079 (defsearchop :bcc :str)
1080 (defsearchop :before :date)
1081 (defsearchop :body :str)
1082 (defsearchop :cc :str)
1083 (defsearchop :deleted)
1084 (defsearchop :draft)
1085 (defsearchop :flagged)
1086 (defsearchop :from :str)
1087 (defsearchop :header :str :str)
1088 (defsearchop :keyword :flag)
1089 (defsearchop :larger :number)
1092 (defsearchop :on :date)
1093 (defsearchop :recent)
1095 (defsearchop :sentbefore :date)
1096 (defsearchop :senton :date)
1097 (defsearchop :sentsince :date)
1098 (defsearchop :since :date)
1099 (defsearchop :smaller :number)
1100 (defsearchop :subject :str)
1101 (defsearchop :text :str)
1102 (defsearchop :to :str)
1103 (defsearchop :uid :messageset)
1104 (defsearchop :unanswered)
1105 (defsearchop :undeleted)
1106 (defsearchop :undraft)
1107 (defsearchop :unflagged)
1108 (defsearchop :unkeyword :flag)
1109 (defsearchop :unseen)
1113 (defun build-search-string (search)
1114 ;; take the lisp search form and turn it into a string that can be
1119 else (let ((str (make-string-output-stream)))
1120 (bss-int search str)
1121 (get-output-stream-string str))))
1123 (defun bss-int (search str)
1124 ;;* it turns out that imap (on linux) is very picky about spaces....
1125 ;; any extra whitespace will result in failed searches
1127 (labels ((and-ify (srch str)
1128 (let ((spaceout nil))
1130 (if* spaceout then (format str " "))
1132 (setq spaceout t))))
1134 ; only binary or allowed in imap but we support n-ary
1135 ; or in this interface
1136 (if* (null (cdr srch))
1137 then (bss-int (car srch) str)
1139 then ; over two clauses
1141 (bss-int (car srch) str)
1143 (or-ify (cdr srch) str)
1146 (format str "or (" )
1147 (bss-int (car srch) str)
1149 (bss-int (cadr srch) str)
1152 ;; a sequence of messages
1153 (do* ((xsrch srch (cdr xsrch))
1154 (val (car xsrch) (car xsrch)))
1157 then (format str "~s" val)
1158 elseif (and (consp val)
1160 (eq 3 (length val)))
1161 then (format str "~s:~s" (cadr val) (caddr val))
1162 else (po-error :syntax-error
1163 :format-control "illegal set format ~s"
1164 :format-arguments (list val)))
1165 (if* (cdr xsrch) then (format str ","))))
1166 (arg-process (str args arginfo)
1167 ;; process and print each arg to str
1168 ;; assert (length of args and arginfo are the same)
1169 (do* ((x-args args (cdr x-args))
1170 (val (car x-args) (car x-args))
1171 (x-arginfo arginfo (cdr x-arginfo)))
1173 (ecase (car x-arginfo)
1175 ; print it as a string
1176 (format str " \"~a\"" (car x-args)))
1180 then (setq val (universal-time-to-rfc822-date
1182 elseif (not (stringp val))
1183 then (po-error :syntax-error
1184 :format-control "illegal value for date search ~s"
1185 :format-arguments (list val)))
1186 ;; val is now a string
1187 (format str " ~s" val))
1190 (if* (not (integerp val))
1191 then (po-error :syntax-error
1192 :format-control "illegal value for number in search ~s"
1193 :format-arguments (list val)))
1194 (format str " ~s" val))
1197 ;; should be a symbol in the kwd package
1198 (setq val (string val))
1199 (format str " ~s" val))
1202 then (format str " ~s" val)
1204 then (set-ify val str)
1205 else (po-error :syntax-error
1206 :format-control "illegal message set ~s"
1207 :format-arguments (list val))))
1211 (if* (symbolp search)
1212 then (if* (get search 'imap-search-no-args)
1213 then (format str "~a" (string-upcase
1215 else (po-error :syntax-error
1216 :format-control "illegal search word: ~s"
1217 :format-arguments (list search)))
1218 elseif (consp search)
1219 then (case (car search)
1220 (and (if* (null (cdr search))
1221 then (bss-int :all str)
1222 elseif (null (cddr search))
1223 then (bss-int (cadr search) str)
1224 else (and-ify (cdr search) str)))
1225 (or (if* (null (cdr search))
1226 then (bss-int :all str)
1227 elseif (null (cddr search))
1228 then (bss-int (cadr search) str)
1229 else (or-ify (cdr search) str)))
1230 (not (if* (not (eql (length search) 2))
1231 then (po-error :syntax-error
1232 :format-control "not takes one argument: ~s"
1233 :format-arguments (list search)))
1234 (format str "not (" )
1235 (bss-int (cadr search) str)
1238 (set-ify (list search) str))
1240 (if* (and (symbolp (car search))
1241 (setq arginfo (get (car search)
1242 'imap-search-args)))
1244 (format str "~a" (string-upcase
1245 (string (car search))))
1246 (if* (not (equal (length (cdr search))
1248 then (po-error :syntax-error
1249 :format-control "wrong number of arguments to ~s"
1250 :format-arguments search))
1252 (arg-process str (cdr search) arginfo)
1254 elseif (integerp (car search))
1255 then (set-ify search str)
1256 else (po-error :syntax-error
1257 :format-control "Illegal form ~s in search string"
1258 :format-arguments (list search))))))
1259 elseif (integerp search)
1260 then ; a message number
1261 (format str "~s" search)
1262 else (po-error :syntax-error
1263 :format-control "Illegal form ~s in search string"
1264 :format-arguments (list search)))))
1270 (defun parse-mail-header (text)
1271 ;; given the partial text of a mail message that includes
1272 ;; at least the header part, return an assoc list of
1273 ;; (header . content) items
1274 ;; Note that the header is string with most likely mixed case names
1275 ;; as it's conventional to capitalize header names.
1282 (labels ((next-header-line ()
1283 ;; find the next header line return
1285 ;; :start - beginning of header value, header and
1287 ;; :continue - continuation of previous header line
1291 beginv ; charpos beginning value
1292 beginh ; charpos beginning header
1297 (return-from next-header-line
1299 (loop ; for each character
1304 (setq ch (char text next))
1305 (if* (eq ch #\return)
1306 thenret ; ignore return, (handle following linefeed)
1308 (1 ; no characters seen
1309 (if* (eq ch #\linefeed)
1317 else (setq beginh next)
1320 (2 ; looking for first non blank in value
1321 (if* (eq ch #\linefeed)
1322 then ; empty continuation line, ignore
1325 elseif (not (member ch
1329 then ; begin value part
1332 (3 ; reading the header
1333 (if* (eq ch #\linefeed)
1334 then ; bogus header line, ignore
1338 (subseq text beginh next))
1340 (4 ; looking for the end of the value
1341 (if* (eq ch #\linefeed)
1352 else :continue))))))
1357 (loop ; for each header line
1359 (if* (eq :eof (setq kind (next-header-line)))
1362 (:start (push (cons header value) headers))
1365 then ; append to previous one
1366 (setf (cdr (car headers))
1367 (concatenate 'string (cdr (car headers))
1371 (subseq text next end))))
1374 (defun make-envelope-from-text (text)
1375 ;; given at least the headers part of a message return
1376 ;; an envelope structure containing the contents
1377 ;; This is useful for parsing the headers of things returned by
1380 (let ((headers (parse-mail-header text)))
1383 :date (cdr (assoc "date" headers :test #'equalp))
1384 :subject (cdr (assoc "subject" headers :test #'equalp))
1385 :from (cdr (assoc "from" headers :test #'equalp))
1386 :sender (cdr (assoc "sender" headers :test #'equalp))
1387 :reply-to (cdr (assoc "reply-to" headers :test #'equalp))
1388 :to (cdr (assoc "to" headers :test #'equalp))
1389 :cc (cdr (assoc "cc" headers :test #'equalp))
1390 :bcc (cdr (assoc "bcc" headers :test #'equalp))
1391 :in-reply-to (cdr (assoc "in-reply-to" headers :test #'equalp))
1392 :message-id (cdr (assoc "message-id" headers :test #'equalp))
1404 (defmethod get-and-parse-from-imap-server ((mb imap-mailbox))
1405 ;; read the next line and parse it
1408 (multiple-value-bind (line count)
1409 (get-line-from-server mb)
1411 then (format t "from server: ")
1412 (dotimes (i count)(write-char (schar line i)))
1416 (parse-imap-response line count)
1421 (defmethod get-and-parse-from-pop-server ((mb pop-mailbox))
1422 ;; read the next line from the pop server
1426 ;; a list of rest of the tokens on the line
1427 ;; the whole line after the +ok or -err
1429 (multiple-value-bind (line count)
1430 (get-line-from-server mb)
1433 then (format t "from server: " count)
1434 (dotimes (i count)(write-char (schar line i)))
1437 (parse-pop-response line count)))
1441 ;; Parse and return the data from each line
1443 ;; tag -- either a string or the symbol :untagged
1444 ;; command -- a keyword symbol naming the command, like :ok
1445 ;; count -- a number which preceeded the command, or nil if
1446 ;; there wasn't a command
1447 ;; bracketted - a list of objects found in []'s after the command
1448 ;; or in ()'s after the command or sometimes just
1449 ;; out in the open after the command (like the search)
1450 ;; comment -- the whole of the part after the command
1452 (defun parse-imap-response (line end)
1453 (let (kind value next
1454 tag count command extra-data
1458 (multiple-value-setq (kind value next)
1459 (get-next-token line 0 end))
1462 (:string (setq tag (if* (equal value "*")
1465 (t (po-error :unexpected
1466 :format-control "Illegal tag on response: ~s"
1467 :format-arguments (list (subseq line 0 count))
1468 :server-string (subseq line 0 end)
1472 (multiple-value-setq (kind value next)
1473 (get-next-token line next end))
1477 (:number (setq count value)
1478 (multiple-value-setq (kind value next)
1479 (get-next-token line next end))
1481 (:string (setq command (kwd-intern value)))
1482 (t (po-error :unexpected
1483 :format-control "Illegal command on response: ~s"
1484 :format-arguments (list (subseq line 0 count))
1485 :server-string (subseq line 0 end)))))
1487 (setq comment (subseq line next end))
1489 ;; now the part after the command... this gets tricky
1491 (multiple-value-setq (kind value next)
1492 (get-next-token line next end))
1495 ((:lbracket :lparen)
1496 (multiple-value-setq (kind value next)
1497 (get-next-sexpr line (1- next) end))
1499 (:sexpr (push value extra-data))
1500 (t (po-error :syntax-error :format-control "bad sexpr form"))))
1502 ((:number :string :nil) (push value extra-data))
1503 (t ; should never happen
1506 (if* (not (member command '(:list :search) :test #'eq))
1507 then ; only one item returned
1508 (setq extra-data (car extra-data))
1511 (if* (member command '(:list :search) :test #'eq)
1512 then (setq extra-data (nreverse extra-data)))
1515 (values tag command count extra-data comment)))
1519 (defun get-next-sexpr (line start end)
1520 ;; read a whole s-expression
1522 ;; kind -- :sexpr or :rparen or :rbracket
1523 ;; value - the sexpr value
1524 ;; next - next charpos to scan
1526 (let ( kind value next)
1527 (multiple-value-setq (kind value next) (get-next-token line start end))
1530 ((:string :number :nil)
1531 (values :sexpr value next))
1532 (:eof (po-error :syntax-error
1533 :format-control "eof inside sexpr"))
1534 ((:lbracket :lparen)
1537 (multiple-value-setq (kind value next)
1538 (get-next-sexpr line next end))
1540 (:sexpr (push value res))
1541 ((:rparen :rbracket)
1542 (return (values :sexpr (nreverse res) next)))
1543 (t (po-error :syntax-error
1544 :format-control "bad sexpression"))))))
1545 ((:rbracket :rparen)
1546 (values kind nil next))
1547 (t (po-error :syntax-error
1548 :format-control "bad sexpression")))))
1551 (defun parse-pop-response (line end)
1554 ;; a list of rest of the tokens on the line, the tokens
1555 ;; being either strings or integers
1556 ;; the whole line after the +ok or -err
1558 (let (res lineres result)
1559 (multiple-value-bind (kind value next)
1560 (get-next-token line 0 end)
1563 (:string (setq result (if* (equal "+OK" value)
1566 (t (po-error :unexpected
1567 :format-control "bad response from server"
1568 :server-string (subseq line 0 end))))
1570 (setq lineres (subseq line next end))
1573 (multiple-value-setq (kind value next)
1574 (get-next-token line next end))
1578 ((:string :number) (push value res))))
1580 (values result (nreverse res) lineres))))
1591 (defparameter *char-to-kind*
1592 (let ((arr (make-array 256 :initial-element nil)))
1594 (do ((i #.(char-code #\0) (1+ i)))
1595 ((> i #.(char-code #\9)))
1596 (setf (aref arr i) :number))
1598 (setf (aref arr #.(char-code #\space)) :space)
1599 (setf (aref arr #.(char-code #\tab)) :space)
1600 (setf (aref arr #.(char-code #\return)) :space)
1601 (setf (aref arr #.(char-code #\linefeed)) :space)
1603 (setf (aref arr #.(char-code #\[)) :lbracket)
1604 (setf (aref arr #.(char-code #\])) :rbracket)
1605 (setf (aref arr #.(char-code #\()) :lparen)
1606 (setf (aref arr #.(char-code #\))) :rparen)
1607 (setf (aref arr #.(char-code #\")) :dquote)
1609 (setf (aref arr #.(char-code #\^b)) :big-string) ; our own invention
1614 (defun get-next-token (line start end)
1615 ;; scan past whitespace for the next token
1616 ;; return three values:
1617 ;; kind: :string , :number, :eof, :lbracket, :rbracket,
1619 ;; value: the value, either a string or number or nil
1620 ;; next: the character pos to start scanning for the next token
1622 (let (ch chkind colstart (count 0) (state :looking)
1623 collector right-bracket-is-normal)
1625 ; pick up the next character
1627 then (if* (eq state :looking)
1628 then (return (values :eof nil start))
1629 else (setq ch #\space))
1630 else (setq ch (schar line start)))
1632 (setq chkind (aref *char-to-kind* (char-code ch)))
1638 (:number (setq state :number)
1639 (setq colstart start)
1640 (setq count (- (char-code ch) #.(char-code #\0))))
1641 ((:lbracket :lparen :rbracket :rparen)
1642 (return (values chkind nil (1+ start))))
1644 (setq collector (make-array 10
1645 :element-type 'character
1648 (setq state :qstring))
1650 (setq colstart (1+ start))
1651 (setq state :big-string))
1652 (t (setq colstart start)
1653 (setq state :literal))))
1656 ((:space :lbracket :lparen :rbracket :rparen
1657 :dquote) ; end of number
1658 (return (values :number count start)))
1659 (:number ; more number
1660 (setq count (+ (* count 10)
1661 (- (char-code ch) #.(char-code #\0)))))
1662 (t ; turn into an literal
1663 (setq state :literal))))
1666 ((:space :rbracket :lparen :rparen :dquote) ; end of literal
1667 (if* (and (eq chkind :rbracket)
1668 right-bracket-is-normal)
1669 then nil ; don't stop now
1670 else (let ((seq (subseq line colstart start)))
1671 (if* (equal "NIL" seq)
1672 then (return (values :nil
1675 else (return (values :string
1678 (t (if* (eq chkind :lbracket)
1679 then ; imbedded left bracket so right bracket isn't
1681 (setq right-bracket-is-normal t))
1685 ; (format t "start is ~s kind is ~s~%" start chkind)
1689 (return (values :string collector (1+ start))))
1691 then ; escaping the next character
1694 then (po-error :unexpected
1695 :format-control "eof in string returned"))
1696 (setq ch (schar line start)))
1697 (vector-push-extend ch collector)
1700 then ; we overran the end of the input
1701 (po-error :unexpected
1702 :format-control "eof in string returned")))))
1704 ;; super string... just a block of data
1705 ; (format t "start is ~s kind is ~s~%" start chkind)
1709 (return (values :string
1710 (subseq line colstart start)
1721 ; this used to be exported from the excl package
1723 (defvar *keyword-package* (find-package :keyword))
1726 (defun kwd-intern (string)
1727 ;; convert the string to the current preferred case
1729 (intern (case excl::*current-case-mode*
1730 ((:case-sensitive-lower
1731 :case-insensitive-lower) (string-downcase string))
1732 (t (string-upcase string)))
1748 ;; low level i/o to server
1750 (defun get-line-from-server (mailbox)
1751 ;; Return two values: a buffer and a character count.
1752 ;; The character count includes up to but excluding the cr lf that
1753 ;; was read from the socket.
1755 (let* ((buff (get-line-buffer 0))
1758 (p (post-office-socket mailbox))
1764 (flet ((grow-buffer (size)
1765 (let ((newbuff (get-line-buffer size)))
1767 (setf (schar newbuff j) (schar buff j)))
1768 (free-line-buffer buff)
1770 (setq len (length buff)))))
1772 ;; increase the buffer to at least size
1773 ;; this is somewhat complex to ensure that we aren't doing
1774 ;; buffer allocation within the with-timeout form, since
1775 ;; that could trigger a gc which could then cause the
1776 ;; with-timeout form to expire.
1780 then ; we should now read in this may bytes and
1781 ; append it to this buffer
1782 (multiple-value-bind (ans this-count)
1783 (get-block-of-data-from-server mailbox whole-count)
1784 ; now put this data in the current buffer
1785 (if* (> (+ i whole-count 5) len)
1786 then ; grow the initial buffer
1787 (grow-buffer (+ i whole-count 100)))
1789 (dotimes (ind this-count)
1790 (setf (schar buff i) (schar ans ind))
1792 (setf (schar buff i) #\^b) ; end of inset string
1794 (free-line-buffer ans)
1795 (setq whole-count nil)
1798 then ; we're growing the buffer holding the line data
1799 (grow-buffer (+ len 200))
1800 (setf (schar buff i) ch)
1805 (mp:with-timeout ((timeout mailbox)
1807 :format-control "imap server failed to respond"))
1808 ;; read up to lf (lf most likely preceeded by cr)
1810 (setq ch (read-char p))
1811 (if* (eq #\linefeed ch)
1812 then ; end of line. Don't save the return
1814 (eq (schar buff (1- i)) #\return))
1815 then ; remove #\return, replace with newline
1817 (setf (schar buff i) #\newline)
1819 ;; must check for an extended return value which
1820 ;; is indicated by a {nnn} at the end of the line
1823 (if* (and (>= i 0) (eq (schar buff ind) #\}))
1824 then (let ((count 0)
1829 then ; no of the form {nnn}
1830 (return-from count-check))
1831 (setf ch (schar buff ind))
1833 then ; must now read that many bytes
1834 (setf (schar buff ind) #\^b)
1835 (setq whole-count count)
1837 (return-from timeout)
1838 elseif (<= #.(char-code #\0)
1846 #.(char-code #\0)))))
1847 (setq mult (* 10 mult))
1848 else ; invalid form, get out
1849 (return-from count-check)))))))
1852 (return-from get-line-from-server
1854 else ; save character
1856 then ; need bigger buffer
1858 (setf (schar buff i) ch)
1861 ;; most likely error is that the server went away
1862 (ignore-errors (close p))
1863 (po-error :server-shutdown-connection
1864 :format-control "condition signalled: ~a~%most likely server shut down the connection."
1865 :format-arguments (list con)))
1869 (defun get-block-of-data-from-server (mb count &key save-returns)
1870 ;; read count bytes from the server returning it in a line buffer object
1871 ;; return as a second value the number of characters saved
1872 ;; (we drop #\return's so that lines are sepisarated by a #\newline
1873 ;; like lisp likes).
1875 (let ((buff (get-line-buffer count))
1876 (p (post-office-socket mb))
1878 (mp:with-timeout ((timeout mb)
1880 :format-control "imap server timed out"))
1883 (if* (eq #\return (setf (schar buff ind) (read-char p)))
1884 then (if* save-returns then (incf ind)) ; drop #\returns
1888 (values buff ind))))
1891 ;;-- reusable line buffers
1893 (defvar *line-buffers* nil)
1895 (defun get-line-buffer (size)
1896 ;; get a buffer of at least size bytes
1897 (setq size (min size (1- array-total-size-limit)))
1898 (mp::without-scheduling
1899 (dolist (buff *line-buffers* (make-string size))
1900 (if* (>= (length buff) size)
1902 (setq *line-buffers* (delete buff *line-buffers*))
1906 (defun free-line-buffer (buff)
1907 (mp:without-scheduling
1908 (push buff *line-buffers*)))
1910 (defun init-line-buffer (new old)
1911 ;; copy old into new
1912 (declare (optimize (speed 3)))
1913 (dotimes (i (length old))
1914 (declare (fixnum i))
1915 (setf (schar new i) (schar old i))))
1924 (defun universal-time-to-rfc822-date (ut)
1925 ;; convert a lisp universal time to rfc 822 date
1927 (multiple-value-bind
1928 (sec min hour date month year day-of-week dsp time-zone)
1929 (decode-universal-time ut 0)
1930 (declare (ignore time-zone sec min hour day-of-week dsp time-zone))
1931 (format nil "~d-~a-~d"
1934 '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
1935 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")