X-Git-Url: http://git.kpe.io/?p=postoffice.git;a=blobdiff_plain;f=imap.lisp;h=0cd5bfd2fbfaed0d91621f943462f35f01b11f30;hp=b873bca2772c0b5266a2ec28fa9867eb792e0e29;hb=HEAD;hpb=9a613ba731125584906aeb4886869428e2c3ba32 diff --git a/imap.lisp b/imap.lisp index b873bca..0cd5bfd 100644 --- a/imap.lisp +++ b/imap.lisp @@ -49,25 +49,25 @@ (defclass post-office () ((socket :initarg :socket - :accessor post-office-socket) - + :accessor post-office-socket) + (host :initarg :host - :accessor post-office-host - :initform nil) + :accessor post-office-host + :initform nil) (user :initarg :user - :accessor post-office-user - :initform nil) - + :accessor post-office-user + :initform nil) + (state :accessor post-office-state - :initarg :state - :initform :unconnected) - - (timeout + :initarg :state + :initform :unconnected) + + (timeout ;; time to wait for network activity for actions that should ;; happen very quickly when things are operating normally :initarg :timeout :initform 60 - :accessor timeout) + :accessor timeout) )) (defclass imap-mailbox (post-office) @@ -75,41 +75,41 @@ :accessor mailbox-name :initform nil) - (separator + (separator ;; string that separates mailbox names in the hierarchy :accessor mailbox-separator :initform "") - + ;;; these slots hold information about the currently selected mailbox: - + (message-count ; how many in the mailbox :accessor mailbox-message-count :initform 0) - + (recent-messages ; how many messages since we last checked :accessor mailbox-recent-messages :initform 0) - + (uidvalidity ; used to denote messages uniquely - :accessor mailbox-uidvalidity + :accessor mailbox-uidvalidity :initform 0) - - (uidnext + + (uidnext :accessor mailbox-uidnext ;; predicted next uid :initform 0) - - (flags ; list of flags that can be stored in a message - :accessor mailbox-flags + + (flags ; list of flags that can be stored in a message + :accessor mailbox-flags :initform nil) - + (permanent-flags ; list of flags that be stored permanently :accessor mailbox-permanent-flags :initform nil) - + (first-unseen ; number of the first unseen message :accessor first-unseen :initform 0) - + ;;; end list of values for the currently selected mailbox ) ) @@ -148,7 +148,7 @@ name ;; often the person's full name additional mailbox ;; the login name - host ;; the name of the machine + host ;; the name of the machine ) @@ -163,59 +163,59 @@ ; All our conditions are po-condition or po-error (which is a subclass of ; po-condition). ; -; A condition will have a server-string value if it as initiated by +; A condition will have a server-string value if it as initiated by ; something returned by the server. -; A condition will have a format-control value if we want to display -; something we generated in response to -; +; A condition will have a format-control value if we want to display +; something we generated in response to +; ; ; ;; identifiers used in conditions/errors ; :problem condition -; the server responded with 'no' followed by an explanation. -; this mean that something unusual happend and doesn't necessarily -; mean that the command has completely failed (but it might). -; +; the server responded with 'no' followed by an explanation. +; this mean that something unusual happend and doesn't necessarily +; mean that the command has completely failed (but it might). +; ; :unknown-ok condition -; the server responded with an 'ok' followed by something -; we don't recognize. It's probably safe to ignore this. +; the server responded with an 'ok' followed by something +; we don't recognize. It's probably safe to ignore this. ; ; :unknown-untagged condition -; the server responded with some untagged command we don't -; recognize. it's probaby ok to ignore this. +; the server responded with some untagged command we don't +; recognize. it's probaby ok to ignore this. ; ; :error-response error -; the command failed. +; the command failed. ; ; :syntax-error error -; the data passed to a function in this interface was malformed +; the data passed to a function in this interface was malformed ; ; :unexpected error -; the server responded an unexpected way. +; the server responded an unexpected way. ; ; :server-shutdown-connection error -; the server has shut down the connection, don't attempt to +; the server has shut down the connection, don't attempt to ; send any more commands to this connection, or even close it. ; ; :timeout error -; server failed to respond within the timeout period +; server failed to respond within the timeout period ; ; :response-too-large error -; contents of a response is too large to store in a Lisp array. +; contents of a response is too large to store in a Lisp array. ;; conditions (define-condition po-condition () ;; used to notify user of things that shouldn't necessarily stop ;; program flow - ((identifier + ((identifier ;; keyword identifying the error (or :unknown) - :reader po-condition-identifier + :reader po-condition-identifier :initform :unknown :initarg :identifier ) - (server-string + (server-string ;; message from the imap server :reader po-condition-server-string :initform "" @@ -224,23 +224,23 @@ (:report (lambda (con stream) (with-slots (identifier server-string) con - ;; a condition either has a server-string or it has a + ;; a condition either has a server-string or it has a ;; format-control string (format stream "Post Office condition: ~s~%" identifier) #+allegro (if* (and (slot-boundp con 'excl::format-control) - (excl::simple-condition-format-control con)) - then (apply #'format stream - (excl::simple-condition-format-control con) - (excl::simple-condition-format-arguments con))) + (excl::simple-condition-format-control con)) + then (apply #'format stream + (excl::simple-condition-format-control con) + (excl::simple-condition-format-arguments con))) (if* server-string - then (format stream - "~&Message from server: ~s" - (string-left-trim " " server-string))))))) - - + then (format stream + "~&Message from server: ~s" + (string-left-trim " " server-string))))))) -(define-condition po-error (po-condition error) + + +(define-condition po-error (po-condition error) ;; used to denote things that should stop program flow ()) @@ -248,24 +248,24 @@ ;; aignalling the conditions -(defun po-condition (identifier &key server-string format-control - format-arguments) +(defun po-condition (identifier &key server-string format-control + format-arguments) (signal (make-instance 'po-condition - :identifier identifier - :server-string server-string - :format-control format-control - :format-arguments format-arguments - ))) - + :identifier identifier + :server-string server-string + :format-control format-control + :format-arguments format-arguments + ))) + (defun po-error (identifier &key server-string - format-control format-arguments) + format-control format-arguments) (error (make-instance 'po-error - :identifier identifier - :server-string server-string - :format-control format-control - :format-arguments format-arguments))) + :identifier identifier + :server-string server-string + :format-control format-control + :format-arguments format-arguments))) + - ;---------------------------------------------- @@ -283,63 +283,63 @@ (setf (aref str 1) #\linefeed) str)) -(defun make-imap-connection (host &key (port 143) - user - password - (timeout 30)) +(defun make-imap-connection (host &key (port 143) + user + password + (timeout 30)) (let* ((sock (make-socket :remote-host host - :remote-port port)) - (imap (make-instance 'imap-mailbox - :socket sock - :host host - :timeout timeout - :state :unauthorized))) - + :remote-port port)) + (imap (make-instance 'imap-mailbox + :socket sock + :host host + :timeout timeout + :state :unauthorized))) + (multiple-value-bind (tag cmd count extra comment) - (get-and-parse-from-imap-server imap) + (get-and-parse-from-imap-server imap) (declare (ignore cmd count extra)) (if* (not (eq :untagged tag)) - then (po-error :error-response - :server-string comment))) - + then (po-error :error-response + :server-string comment))) + ; now login - (send-command-get-results imap - (format nil "login ~a ~a" user password) - #'handle-untagged-response - #'(lambda (mb command count extra comment) - (check-for-success mb command count extra - comment - "login"))) - + (send-command-get-results imap + (format nil "login ~a ~a" user password) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success mb command count extra + comment + "login"))) + ; find the separator character (let ((res (mailbox-list imap))) - ;; + ;; (let ((sep (cadr (car res)))) - (if* sep - then (setf (mailbox-separator imap) sep)))) - - - + (if* sep + then (setf (mailbox-separator imap) sep)))) + + + imap)) (defmethod close-connection ((mb imap-mailbox)) - + (let ((sock (post-office-socket mb))) (if* sock then (ignore-errors - (send-command-get-results - mb - "logout" - ; don't want to get confused by untagged - ; bye command, which is expected here - #'(lambda (mb command count extra) - (declare (ignore mb command count extra)) - nil) - #'(lambda (mb command count extra comment) - (check-for-success mb command count extra - comment - "logout"))))) + (send-command-get-results + mb + "logout" + ; don't want to get confused by untagged + ; bye command, which is expected here + #'(lambda (mb command count extra) + (declare (ignore mb command count extra)) + nil) + #'(lambda (mb command count extra comment) + (check-for-success mb command count extra + comment + "logout"))))) (setf (post-office-socket mb) nil) (if* sock then (ignore-errors (close sock))) t)) @@ -349,9 +349,9 @@ (let ((sock (post-office-socket pb))) (if* sock then (ignore-errors - (send-pop-command-get-results - pb - "QUIT"))) + (send-pop-command-get-results + pb + "QUIT"))) (setf (post-office-socket pb) nil) (if* sock then (ignore-errors (close sock))) t)) @@ -359,62 +359,62 @@ (defun make-pop-connection (host &key (port 110) - user - password - (timeout 30)) + user + password + (timeout 30)) (let* ((sock (make-socket :remote-host host - :remote-port port)) - (pop (make-instance 'pop-mailbox - :socket sock - :host host - :timeout timeout - :state :unauthorized))) - + :remote-port port)) + (pop (make-instance 'pop-mailbox + :socket sock + :host host + :timeout timeout + :state :unauthorized))) + (multiple-value-bind (result) - (get-and-parse-from-pop-server pop) + (get-and-parse-from-pop-server pop) (if* (not (eq :ok result)) - then (po-error :error-response - :format-control - "unexpected line from server after connect"))) - + then (po-error :error-response + :format-control + "unexpected line from server after connect"))) + ; now login (send-pop-command-get-results pop (format nil "user ~a" user)) (send-pop-command-get-results pop (format nil "pass ~a" password)) (let ((res (send-pop-command-get-results pop "stat"))) (setf (mailbox-message-count pop) (car res))) - - - + + + pop)) - -(defmethod send-command-get-results ((mb imap-mailbox) - command untagged-handler tagged-handler) + +(defmethod send-command-get-results ((mb imap-mailbox) + command untagged-handler tagged-handler) ;; send a command and retrieve results until we get the tagged ;; response for the command we sent ;; (let ((tag (get-next-tag))) (format (post-office-socket mb) - "~a ~a~a" tag command *crlf*) + "~a ~a~a" tag command *crlf*) (force-output (post-office-socket mb)) - + (if* *debug-imap* then (format t - "~a ~a~a" tag command *crlf*) - (force-output)) + "~a ~a~a" tag command *crlf*) + (force-output)) (loop (multiple-value-bind (got-tag cmd count extra comment) - (get-and-parse-from-imap-server mb) - (if* (eq got-tag :untagged) - then (funcall untagged-handler mb cmd count extra comment) - elseif (equal tag got-tag) - then (funcall tagged-handler mb cmd count extra comment) - (return) - else (po-error :error-response - :format-control "received tag ~s out of order" - :format-arguments (list got-tag) - :server-string comment)))))) + (get-and-parse-from-imap-server mb) + (if* (eq got-tag :untagged) + then (funcall untagged-handler mb cmd count extra comment) + elseif (equal tag got-tag) + then (funcall tagged-handler mb cmd count extra comment) + (return) + else (po-error :error-response + :format-control "received tag ~s out of order" + :format-arguments (list got-tag) + :server-string comment)))))) (defun get-next-tag () @@ -422,10 +422,10 @@ (if* tag thenret else (setq *cur-imap-tags* *imap-tags*) - (pop *cur-imap-tags*)))) + (pop *cur-imap-tags*)))) (defun handle-untagged-response (mb command count extra comment) - ;; default function to handle untagged responses, which are + ;; default function to handle untagged responses, which are ;; really just returning general state information about ;; the mailbox (case command @@ -435,23 +435,23 @@ (:bye ; occurs when connection times out or mailbox lock is stolen (ignore-errors (close (post-office-socket mb))) (po-error :server-shutdown-connection - :server-string "server shut down the connection")) + :server-string "server shut down the connection")) (:no ; used when grabbing a lock from another process (po-condition :problem :server-string comment)) (:ok ; a whole variety of things (if* extra - then (if* (equalp (car extra) "unseen") - then (setf (first-unseen mb) (cadr extra)) - elseif (equalp (car extra) "uidvalidity") - then (setf (mailbox-uidvalidity mb) (cadr extra)) - elseif (equalp (car extra) "uidnext") - then (setf (mailbox-uidnext mb) (cadr extra)) - elseif (equalp (car extra) "permanentflags") - then (setf (mailbox-permanent-flags mb) - (mapcar #'kwd-intern (cadr extra))) - else (po-condition :unknown-ok :server-string comment)))) + then (if* (equalp (car extra) "unseen") + then (setf (first-unseen mb) (cadr extra)) + elseif (equalp (car extra) "uidvalidity") + then (setf (mailbox-uidvalidity mb) (cadr extra)) + elseif (equalp (car extra) "uidnext") + then (setf (mailbox-uidnext mb) (cadr extra)) + elseif (equalp (car extra) "permanentflags") + then (setf (mailbox-permanent-flags mb) + (mapcar #'kwd-intern (cadr extra))) + else (po-condition :unknown-ok :server-string comment)))) (t (po-condition :unknown-untagged :server-string comment))) - + ) @@ -459,9 +459,9 @@ (defun send-pop-command-get-results (pop command &optional extrap) ;; send the given command to the pop server ;; if extrap is true and if the response is +ok, then data - ;; will follow the command (up to and excluding the first line consisting + ;; will follow the command (up to and excluding the first line consisting ;; of just a period) - ;; + ;; ;; if the pop server returns an error code we signal a lisp error. ;; otherwise ;; return @@ -470,85 +470,85 @@ ;; (format (post-office-socket pop) "~a~a" command *crlf*) (force-output (post-office-socket pop)) - + (if* *debug-imap* then (format t "~a~a" command *crlf*) - (force-output t)) + (force-output t)) (multiple-value-bind (result parsed line) (get-and-parse-from-pop-server pop) (if* (not (eq result :ok)) then (po-error :error-response - :server-string line)) + :server-string line)) (if* extrap then ;; get the rest of the data - ;; many but not all pop servers return the size of the data - ;; after the +ok, so we use that to initially size the - ;; retreival buffer. - (let ((buf (get-line-buffer (+ (if* (fixnump (car parsed)) - then (car parsed) - else 2048 ; reasonable size - ) - 50))) - (pos 0) - ; states - ; 1 - after lf - ; 2 - seen dot at beginning of line - ; 3 - seen regular char on line - (state 1) - (sock (post-office-socket pop))) - (flet ((add-to-buffer (ch) - (if* (>= pos (length buf)) - then ; grow buffer - (if* (>= (length buf) - (1- array-total-size-limit)) - then ; can't grow it any further - (po-error - :response-too-large - :format-control - "response from mail server is too large to hold in a lisp array")) - (let ((new-buf (get-line-buffer - (* (length buf) 2)))) - (init-line-buffer new-buf buf) - (free-line-buffer buf) - (setq buf new-buf))) - (setf (schar buf pos) ch) - (incf pos))) - (loop - (let ((ch (read-char sock nil nil))) - (if* (null ch) - then (po-error :unexpected - :format-control "premature end of file from server")) - (if* (eq ch #\return) - thenret ; ignore crs - else (case state - (1 (if* (eq ch #\.) - then (setq state 2) - elseif (eq ch #\linefeed) - then (add-to-buffer ch) - ; state stays at 1 - else (add-to-buffer ch) - (setq state 3))) - (2 ; seen first dot - (if* (eq ch #\linefeed) - then ; end of message - (return) - else (add-to-buffer ch) - (setq state 3))) - (3 ; normal reading - (add-to-buffer ch) - (if* (eq ch #\linefeed) - then (setq state 1)))))))) - (prog1 (subseq buf 0 pos) - (free-line-buffer buf))) + ;; many but not all pop servers return the size of the data + ;; after the +ok, so we use that to initially size the + ;; retreival buffer. + (let ((buf (get-line-buffer (+ (if* (fixnump (car parsed)) + then (car parsed) + else 2048 ; reasonable size + ) + 50))) + (pos 0) + ; states + ; 1 - after lf + ; 2 - seen dot at beginning of line + ; 3 - seen regular char on line + (state 1) + (sock (post-office-socket pop))) + (flet ((add-to-buffer (ch) + (if* (>= pos (length buf)) + then ; grow buffer + (if* (>= (length buf) + (1- array-total-size-limit)) + then ; can't grow it any further + (po-error + :response-too-large + :format-control + "response from mail server is too large to hold in a lisp array")) + (let ((new-buf (get-line-buffer + (* (length buf) 2)))) + (init-line-buffer new-buf buf) + (free-line-buffer buf) + (setq buf new-buf))) + (setf (schar buf pos) ch) + (incf pos))) + (loop + (let ((ch (read-char sock nil nil))) + (if* (null ch) + then (po-error :unexpected + :format-control "premature end of file from server")) + (if* (eq ch #\return) + thenret ; ignore crs + else (case state + (1 (if* (eq ch #\.) + then (setq state 2) + elseif (eq ch #\linefeed) + then (add-to-buffer ch) + ; state stays at 1 + else (add-to-buffer ch) + (setq state 3))) + (2 ; seen first dot + (if* (eq ch #\linefeed) + then ; end of message + (return) + else (add-to-buffer ch) + (setq state 3))) + (3 ; normal reading + (add-to-buffer ch) + (if* (eq ch #\linefeed) + then (setq state 1)))))))) + (prog1 (subseq buf 0 pos) + (free-line-buffer buf))) else parsed))) - - - + + + (defun convert-flags-plist (plist) - ;; scan the plist looking for "flags" indicators and + ;; scan the plist looking for "flags" indicators and ;; turn value into a list of symbols rather than strings (do ((xx plist (cddr xx))) ((null xx) plist) @@ -559,16 +559,16 @@ (defmethod select-mailbox ((mb imap-mailbox) name) ;; select the given mailbox (send-command-get-results mb - (format nil "select ~a" name) - #'handle-untagged-response - #'(lambda (mb command count extra comment) - (declare (ignore mb count extra)) - (if* (not (eq command :ok)) - then (po-error - :problem - :format-control - "imap mailbox select failed" - :server-string comment)))) + (format nil "select ~a" name) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (declare (ignore mb count extra)) + (if* (not (eq command :ok)) + then (po-error + :problem + :format-control + "imap mailbox select failed" + :server-string comment)))) (setf (mailbox-name mb) name) t ) @@ -577,42 +577,42 @@ (defmethod fetch-letter ((mb imap-mailbox) number &key uid) ;; return the whole letter (fetch-field number "body[]" - (fetch-parts mb number "body[]" :uid uid) - :uid uid)) + (fetch-parts mb number "body[]" :uid uid) + :uid uid)) (defmethod fetch-letter ((pb pop-mailbox) number &key uid) (declare (ignore uid)) - (send-pop-command-get-results pb - (format nil "RETR ~d" number) - t ; extra stuff - )) + (send-pop-command-get-results pb + (format nil "RETR ~d" number) + t ; extra stuff + )) (defmethod fetch-parts ((mb imap-mailbox) number parts &key uid) (let (res) - (send-command-get-results + (send-command-get-results mb (format nil "~afetch ~a ~a" - (if* uid then "uid " else "") - (message-set-string number) - (or parts "body[]") - ) + (if* uid then "uid " else "") + (message-set-string number) + (or parts "body[]") + ) #'(lambda (mb command count extra comment) - (if* (eq command :fetch) - then (push (list count (internalize-flags extra)) res) - else (handle-untagged-response - mb command count extra comment))) + (if* (eq command :fetch) + then (push (list count (internalize-flags extra)) res) + else (handle-untagged-response + mb command count extra comment))) #'(lambda (mb command count extra comment) - (declare (ignore mb count extra)) - (if* (not (eq command :ok)) - then (po-error :problem - :format-control "imap mailbox fetch failed" - :server-string comment)))) + (declare (ignore mb count extra)) + (if* (not (eq command :ok)) + then (po-error :problem + :format-control "imap mailbox fetch failed" + :server-string comment)))) res)) - + (defun fetch-field (letter-number field-name info &key uid) - ;; given the information from a fetch-letter, return the + ;; given the information from a fetch-letter, return the ;; particular field for the particular letter ;; ;; info is as returned by fetch @@ -623,41 +623,41 @@ ;; the same messagenumber may appear in multiple items (let (use-this) (if* uid - then ; uid appears as a property in the value, not - ; as the top level message sequence number - (do ((xx (cadr item) (cddr xx))) - ((null xx)) - (if* (equalp "uid" (car xx)) - then (if* (eql letter-number (cadr xx)) - then (return (setq use-this t)) - else (return)))) - else ; just a message sequence number - (setq use-this (eql letter-number (car item)))) - + then ; uid appears as a property in the value, not + ; as the top level message sequence number + (do ((xx (cadr item) (cddr xx))) + ((null xx)) + (if* (equalp "uid" (car xx)) + then (if* (eql letter-number (cadr xx)) + then (return (setq use-this t)) + else (return)))) + else ; just a message sequence number + (setq use-this (eql letter-number (car item)))) + (if* use-this - then (do ((xx (cadr item) (cddr xx))) - ((null xx)) - (if* (equalp field-name (car xx)) - then (return-from fetch-field (cadr xx)))))))) + then (do ((xx (cadr item) (cddr xx))) + ((null xx)) + (if* (equalp field-name (car xx)) + then (return-from fetch-field (cadr xx)))))))) + - (defun internalize-flags (stuff) - ;; given a plist like object, look for items labelled "flags" and + ;; given a plist like object, look for items labelled "flags" and ;; convert the contents to internal flags objects (do ((xx stuff (cddr xx))) ((null xx)) (if* (equalp (car xx) "flags") then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))) - (return))) - + (return))) + stuff) - + (defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid) - ;; delete all the mesasges and do the expunge to make + ;; delete all the mesasges and do the expunge to make ;; it permanent if expunge is true (alter-flags mb messages :add-flags :\\deleted :uid uid) (if* expunge then (expunge-mailbox mb))) @@ -666,45 +666,45 @@ ;; delete all the messages. We can't expunge without quitting so ;; we don't expunge (declare (ignore expunge uid)) - - (if* (or (numberp messages) - (and (consp messages) (eq :seq (car messages)))) + + (if* (or (numberp messages) + (and (consp messages) (eq :seq (car messages)))) then (setq messages (list messages))) - + (if* (not (consp messages)) then (po-error :syntax-error - :format-control "expect a mesage number or list of messages, not ~s" - :format-arguments (list messages))) - + :format-control "expect a mesage number or list of messages, not ~s" + :format-arguments (list messages))) + (dolist (message messages) (if* (numberp message) then (send-pop-command-get-results pb - (format nil "DELE ~d" message)) + (format nil "DELE ~d" message)) elseif (and (consp message) (eq :seq (car message))) then (do ((start (cadr message) (1+ start)) - (end (caddr message))) - ((> start end)) - (send-pop-command-get-results pb - (format nil "DELE ~d" start))) + (end (caddr message))) + ((> start end)) + (send-pop-command-get-results pb + (format nil "DELE ~d" start))) else (po-error :syntax-error - :format-control "bad message number ~s" - :format-arguments (list message))))) - - - - + :format-control "bad message number ~s" + :format-arguments (list message))))) + + + + (defmethod noop ((mb imap-mailbox)) ;; just poke the server... keeping it awake and checking for ;; new letters (send-command-get-results mb - "noop" - #'handle-untagged-response - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment - "noop")))) + "noop" + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment + "noop")))) (defmethod noop ((pb pop-mailbox)) @@ -716,110 +716,110 @@ (defmethod unique-id ((pb pop-mailbox) &optional message) ;; if message is given, return the unique id of that - ;; message, + ;; message, ;; if message is not given then return a list of lists: ;; (message unique-id) ;; for all messages not marked as deleted ;; (if* message then (let ((res (send-pop-command-get-results pb - (format nil - "UIDL ~d" - message)))) - (cadr res)) + (format nil + "UIDL ~d" + message)))) + (cadr res)) else ; get all of them - (let* ((res (send-pop-command-get-results pb "UIDL" t)) - (end (length res)) - kind - mnum - mid - (next 0)) - - - (let ((coll)) - (loop - (multiple-value-setq (kind mnum next) - (get-next-token res next end)) - - (if* (eq :eof kind) then (return)) - - (if* (not (eq :number kind)) - then ; hmm. bogus - (po-error :unexpected - :format-control "uidl returned illegal message number in ~s" - :format-arguments (list res))) - - ; now get message id - - (multiple-value-setq (kind mid next) - (get-next-token res next end)) - - (if* (eq :number kind) - then ; looked like a number to the tokenizer, - ; make it a string to be consistent - (setq mid (format nil "~d" mid)) - elseif (not (eq :string kind)) - then ; didn't find the uid - (po-error :unexpected - :format-control "uidl returned illegal message id in ~s" - :format-arguments (list res))) - - (push (list mnum mid) coll)) - - (nreverse coll))))) + (let* ((res (send-pop-command-get-results pb "UIDL" t)) + (end (length res)) + kind + mnum + mid + (next 0)) + + + (let ((coll)) + (loop + (multiple-value-setq (kind mnum next) + (get-next-token res next end)) + + (if* (eq :eof kind) then (return)) + + (if* (not (eq :number kind)) + then ; hmm. bogus + (po-error :unexpected + :format-control "uidl returned illegal message number in ~s" + :format-arguments (list res))) + + ; now get message id + + (multiple-value-setq (kind mid next) + (get-next-token res next end)) + + (if* (eq :number kind) + then ; looked like a number to the tokenizer, + ; make it a string to be consistent + (setq mid (format nil "~d" mid)) + elseif (not (eq :string kind)) + then ; didn't find the uid + (po-error :unexpected + :format-control "uidl returned illegal message id in ~s" + :format-arguments (list res))) + + (push (list mnum mid) coll)) + + (nreverse coll))))) (defmethod top-lines ((pb pop-mailbox) message lines) ;; return the header and the given number of top lines of the message - + (let ((res (send-pop-command-get-results pb - (format nil - "TOP ~d ~d" - message - lines) - t ; extra - ))) + (format nil + "TOP ~d ~d" + message + lines) + t ; extra + ))) res)) - - - - + + + + (defun check-for-success (mb command count extra comment command-string ) (declare (ignore mb count extra)) (if* (not (eq command :ok)) then (po-error :error-response - :format-control "imap ~a failed" - :format-arguments (list command-string) - :server-string comment))) + :format-control "imap ~a failed" + :format-arguments (list command-string) + :server-string comment))) + + - - (defmethod mailbox-list ((mb imap-mailbox) &key (reference "") (pattern "")) ;; return a list of mailbox names with respect to a given (let (res) (send-command-get-results mb - (format nil "list ~s ~s" reference pattern) - #'(lambda (mb command count extra comment) - (if* (eq command :list) - then (push extra res) - else (handle-untagged-response - mb command count extra - comment))) - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment "list"))) - + (format nil "list ~s ~s" reference pattern) + #'(lambda (mb command count extra comment) + (if* (eq command :list) + then (push extra res) + else (handle-untagged-response + mb command count extra + comment))) + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "list"))) + ;; the car of each list is a set of keywords, make that so (dolist (rr res) (setf (car rr) (mapcar #'kwd-intern (car rr)))) - + res - - + + )) @@ -827,12 +827,12 @@ ;; create a mailbox name of the given name. ;; use mailbox-separator if you want to create a hierarchy (send-command-get-results mb - (format nil "create ~s" mailbox-name) - #'handle-untagged-response - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment "create"))) + (format nil "create ~s" mailbox-name) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "create"))) t) @@ -840,33 +840,33 @@ ;; create a mailbox name of the given name. ;; use mailbox-separator if you want to create a hierarchy (send-command-get-results mb - (format nil "delete ~s" mailbox-name) - #'handle-untagged-response - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment "delete")))) + (format nil "delete ~s" mailbox-name) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "delete")))) (defmethod rename-mailbox ((mb imap-mailbox) old-mailbox-name new-mailbox-name) ;; create a mailbox name of the given name. ;; use mailbox-separator if you want to create a hierarchy (send-command-get-results mb - (format nil "rename ~s ~s" - old-mailbox-name - new-mailbox-name) - #'handle-untagged-response - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment - "rename")))) + (format nil "rename ~s ~s" + old-mailbox-name + new-mailbox-name) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment + "rename")))) (defmethod alter-flags ((mb imap-mailbox) - messages &key (flags nil flags-p) - add-flags remove-flags - silent uid) + messages &key (flags nil flags-p) + add-flags remove-flags + silent uid) ;; ;; change the flags using the store command ;; @@ -878,112 +878,112 @@ elseif remove-flags then (setq cmd "-flags" val remove-flags) else (return-from alter-flags nil)) - + (if* (atom val) then (setq val (list val))) - + (send-command-get-results mb - (format nil "~astore ~a ~a~a ~a" - (if* uid then "uid " else "") - (message-set-string messages) - cmd - (if* silent - then ".silent" - else "") - (if* val - thenret - else "()")) - #'(lambda (mb command count extra comment) - (if* (eq command :fetch) - then (push (list count - (convert-flags-plist - extra)) - res) - else (handle-untagged-response - mb command count extra - comment))) - - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment "store"))) + (format nil "~astore ~a ~a~a ~a" + (if* uid then "uid " else "") + (message-set-string messages) + cmd + (if* silent + then ".silent" + else "") + (if* val + thenret + else "()")) + #'(lambda (mb command count extra comment) + (if* (eq command :fetch) + then (push (list count + (convert-flags-plist + extra)) + res) + else (handle-untagged-response + mb command count extra + comment))) + + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "store"))) res)) (defun message-set-string (messages) ;; return a string that describes the messages which may be a ;; single number or a sequence of numbers - + (if* (atom messages) then (format nil "~a" messages) else (if* (and (consp messages) - (eq :seq (car messages))) - then (format nil "~a:~a" (cadr messages) (caddr messages)) - else (let ((str (make-string-output-stream)) - (precomma nil)) - (dolist (msg messages) - (if* precomma then (format str ",")) - (if* (atom msg) - then (format str "~a" msg) - elseif (eq :seq (car msg)) - then (format str - "~a:~a" (cadr msg) (caddr msg)) - else (po-error :syntax-error - :format-control "bad message list ~s" - :format-arguments (list msg))) - (setq precomma t)) - (get-output-stream-string str))))) - - - - - - + (eq :seq (car messages))) + then (format nil "~a:~a" (cadr messages) (caddr messages)) + else (let ((str (make-string-output-stream)) + (precomma nil)) + (dolist (msg messages) + (if* precomma then (format str ",")) + (if* (atom msg) + then (format str "~a" msg) + elseif (eq :seq (car msg)) + then (format str + "~a:~a" (cadr msg) (caddr msg)) + else (po-error :syntax-error + :format-control "bad message list ~s" + :format-arguments (list msg))) + (setq precomma t)) + (get-output-stream-string str))))) + + + + + + (defmethod expunge-mailbox ((mb imap-mailbox)) ;; remove messages marked as deleted (let (res) (send-command-get-results mb - "expunge" - #'(lambda (mb command count extra - comment) - (if* (eq command :expunge) - then (push count res) - else (handle-untagged-response - mb command count extra - comment))) - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment "expunge"))) + "expunge" + #'(lambda (mb command count extra + comment) + (if* (eq command :expunge) + then (push count res) + else (handle-untagged-response + mb command count extra + comment))) + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "expunge"))) (nreverse res))) - - - + + + (defmethod close-mailbox ((mb imap-mailbox)) ;; remove messages marked as deleted (send-command-get-results mb - "close" - #'handle-untagged-response - - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment "close"))) + "close" + #'handle-untagged-response + + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "close"))) t) - + (defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination - &key uid) + &key uid) (send-command-get-results mb - (format nil "~acopy ~a ~s" - (if* uid then "uid " else "") - (message-set-string message-list) - destination) - #'handle-untagged-response - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment "copy"))) + (format nil "~acopy ~a ~s" + (if* uid then "uid " else "") + (message-set-string message-list) + destination) + #'handle-untagged-response + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "copy"))) t) @@ -992,22 +992,22 @@ (defmethod search-mailbox ((mb imap-mailbox) search-expression &key uid) (let (res) (send-command-get-results mb - (format nil "~asearch ~a" - (if* uid then "uid " else "") - (build-search-string search-expression)) - #'(lambda (mb command count extra comment) - (if* (eq command :search) - then (setq res (append res extra)) - else (handle-untagged-response - mb command count extra - comment))) - #'(lambda (mb command count extra comment) - (check-for-success - mb command count extra - comment "search"))) + (format nil "~asearch ~a" + (if* uid then "uid " else "") + (build-search-string search-expression)) + #'(lambda (mb command count extra comment) + (if* (eq command :search) + then (setq res (append res extra)) + else (handle-untagged-response + mb command count extra + comment))) + #'(lambda (mb command count extra comment) + (check-for-success + mb command count extra + comment "search"))) res)) - - + + (defmacro defsearchop (name &rest operands) (if* (null operands) then `(setf (get ',name 'imap-search-no-args) t) @@ -1056,258 +1056,258 @@ (if* (null search) then "" else (let ((str (make-string-output-stream))) - (bss-int search str) - (get-output-stream-string str)))) + (bss-int search str) + (get-output-stream-string str)))) (defun bss-int (search str) ;;* it turns out that imap (on linux) is very picky about spaces.... ;; any extra whitespace will result in failed searches ;; (labels ((and-ify (srch str) - (let ((spaceout nil)) - (dolist (xx srch) - (if* spaceout then (format str " ")) - (bss-int xx str) - (setq spaceout t)))) - (or-ify (srch str) - ; only binary or allowed in imap but we support n-ary - ; or in this interface - (if* (null (cdr srch)) - then (bss-int (car srch) str) - elseif (cddr srch) - then ; over two clauses - (format str "or (") - (bss-int (car srch) str) - (format str ") (") - (or-ify (cdr srch) str) - (format str ")") - else ; 2 args - (format str "or (" ) - (bss-int (car srch) str) - (format str ") (") - (bss-int (cadr srch) str) - (format str ")"))) - (set-ify (srch str) - ;; a sequence of messages - (do* ((xsrch srch (cdr xsrch)) - (val (car xsrch) (car xsrch))) - ((null xsrch)) - (if* (integerp val) - then (format str "~s" val) - elseif (and (consp val) - (eq :seq (car val)) - (eq 3 (length val))) - then (format str "~s:~s" (cadr val) (caddr val)) - else (po-error :syntax-error - :format-control "illegal set format ~s" - :format-arguments (list val))) - (if* (cdr xsrch) then (format str ",")))) - (arg-process (str args arginfo) - ;; process and print each arg to str - ;; assert (length of args and arginfo are the same) - (do* ((x-args args (cdr x-args)) - (val (car x-args) (car x-args)) - (x-arginfo arginfo (cdr x-arginfo))) - ((null x-args)) - (ecase (car x-arginfo) - (:str - ; print it as a string - (format str " \"~a\"" (car x-args))) - (:date - - (if* (integerp val) - then (setq val (universal-time-to-rfc822-date - val)) - elseif (not (stringp val)) - then (po-error :syntax-error - :format-control "illegal value for date search ~s" - :format-arguments (list val))) - ;; val is now a string - (format str " ~s" val)) - (:number - - (if* (not (integerp val)) - then (po-error :syntax-error - :format-control "illegal value for number in search ~s" - :format-arguments (list val))) - (format str " ~s" val)) - (:flag - - ;; should be a symbol in the kwd package - (setq val (string val)) - (format str " ~s" val)) - (:messageset - (if* (numberp val) - then (format str " ~s" val) - elseif (consp val) - then (set-ify val str) - else (po-error :syntax-error - :format-control "illegal message set ~s" - :format-arguments (list val)))) - - )))) - + (let ((spaceout nil)) + (dolist (xx srch) + (if* spaceout then (format str " ")) + (bss-int xx str) + (setq spaceout t)))) + (or-ify (srch str) + ; only binary or allowed in imap but we support n-ary + ; or in this interface + (if* (null (cdr srch)) + then (bss-int (car srch) str) + elseif (cddr srch) + then ; over two clauses + (format str "or (") + (bss-int (car srch) str) + (format str ") (") + (or-ify (cdr srch) str) + (format str ")") + else ; 2 args + (format str "or (" ) + (bss-int (car srch) str) + (format str ") (") + (bss-int (cadr srch) str) + (format str ")"))) + (set-ify (srch str) + ;; a sequence of messages + (do* ((xsrch srch (cdr xsrch)) + (val (car xsrch) (car xsrch))) + ((null xsrch)) + (if* (integerp val) + then (format str "~s" val) + elseif (and (consp val) + (eq :seq (car val)) + (eq 3 (length val))) + then (format str "~s:~s" (cadr val) (caddr val)) + else (po-error :syntax-error + :format-control "illegal set format ~s" + :format-arguments (list val))) + (if* (cdr xsrch) then (format str ",")))) + (arg-process (str args arginfo) + ;; process and print each arg to str + ;; assert (length of args and arginfo are the same) + (do* ((x-args args (cdr x-args)) + (val (car x-args) (car x-args)) + (x-arginfo arginfo (cdr x-arginfo))) + ((null x-args)) + (ecase (car x-arginfo) + (:str + ; print it as a string + (format str " \"~a\"" (car x-args))) + (:date + + (if* (integerp val) + then (setq val (universal-time-to-rfc822-date + val)) + elseif (not (stringp val)) + then (po-error :syntax-error + :format-control "illegal value for date search ~s" + :format-arguments (list val))) + ;; val is now a string + (format str " ~s" val)) + (:number + + (if* (not (integerp val)) + then (po-error :syntax-error + :format-control "illegal value for number in search ~s" + :format-arguments (list val))) + (format str " ~s" val)) + (:flag + + ;; should be a symbol in the kwd package + (setq val (string val)) + (format str " ~s" val)) + (:messageset + (if* (numberp val) + then (format str " ~s" val) + elseif (consp val) + then (set-ify val str) + else (po-error :syntax-error + :format-control "illegal message set ~s" + :format-arguments (list val)))) + + )))) + (if* (symbolp search) then (if* (get search 'imap-search-no-args) - then (format str "~a" (string-upcase - (string search))) - else (po-error :syntax-error - :format-control "illegal search word: ~s" - :format-arguments (list search))) + then (format str "~a" (string-upcase + (string search))) + else (po-error :syntax-error + :format-control "illegal search word: ~s" + :format-arguments (list search))) elseif (consp search) then (case (car search) - (and (if* (null (cdr search)) - then (bss-int :all str) - elseif (null (cddr search)) - then (bss-int (cadr search) str) - else (and-ify (cdr search) str))) - (or (if* (null (cdr search)) - then (bss-int :all str) - elseif (null (cddr search)) - then (bss-int (cadr search) str) - else (or-ify (cdr search) str))) - (not (if* (not (eql (length search) 2)) - then (po-error :syntax-error - :format-control "not takes one argument: ~s" - :format-arguments (list search))) - (format str "not (" ) - (bss-int (cadr search) str) - (format str ")")) - (:seq - (set-ify (list search) str)) - (t (let (arginfo) - (if* (and (symbolp (car search)) - (setq arginfo (get (car search) - 'imap-search-args))) - then - (format str "~a" (string-upcase - (string (car search)))) - (if* (not (equal (length (cdr search)) - (length arginfo))) - then (po-error :syntax-error - :format-control "wrong number of arguments to ~s" - :format-arguments search)) - - (arg-process str (cdr search) arginfo) - - elseif (integerp (car search)) - then (set-ify search str) - else (po-error :syntax-error - :format-control "Illegal form ~s in search string" - :format-arguments (list search)))))) + (and (if* (null (cdr search)) + then (bss-int :all str) + elseif (null (cddr search)) + then (bss-int (cadr search) str) + else (and-ify (cdr search) str))) + (or (if* (null (cdr search)) + then (bss-int :all str) + elseif (null (cddr search)) + then (bss-int (cadr search) str) + else (or-ify (cdr search) str))) + (not (if* (not (eql (length search) 2)) + then (po-error :syntax-error + :format-control "not takes one argument: ~s" + :format-arguments (list search))) + (format str "not (" ) + (bss-int (cadr search) str) + (format str ")")) + (:seq + (set-ify (list search) str)) + (t (let (arginfo) + (if* (and (symbolp (car search)) + (setq arginfo (get (car search) + 'imap-search-args))) + then + (format str "~a" (string-upcase + (string (car search)))) + (if* (not (equal (length (cdr search)) + (length arginfo))) + then (po-error :syntax-error + :format-control "wrong number of arguments to ~s" + :format-arguments search)) + + (arg-process str (cdr search) arginfo) + + elseif (integerp (car search)) + then (set-ify search str) + else (po-error :syntax-error + :format-control "Illegal form ~s in search string" + :format-arguments (list search)))))) elseif (integerp search) then ; a message number - (format str "~s" search) + (format str "~s" search) else (po-error :syntax-error - :format-control "Illegal form ~s in search string" - :format-arguments (list search))))) + :format-control "Illegal form ~s in search string" + :format-arguments (list search))))) -(defun parse-mail-header (text) +(defun parse-mail-header (text) ;; given the partial text of a mail message that includes ;; at least the header part, return an assoc list of ;; (header . content) items ;; Note that the header is string with most likely mixed case names ;; as it's conventional to capitalize header names. (let ((next 0) - (end (length text)) - header - value - kind - headers) + (end (length text)) + header + value + kind + headers) (labels ((next-header-line () - ;; find the next header line return - ;; :eof - no more - ;; :start - beginning of header value, header and - ;; value set - ;; :continue - continuation of previous header line - - - (let ((state 1) - beginv ; charpos beginning value - beginh ; charpos beginning header - ch - ) - (tagbody again - - (return-from next-header-line - - (loop ; for each character - - (if* (>= next end) - then (return :eof)) - - (setq ch (char text next)) - (if* (eq ch #\return) - thenret ; ignore return, (handle following linefeed) - else (case state - (1 ; no characters seen - (if* (eq ch #\linefeed) - then (incf next) - (return :eof) - elseif (member ch - '(#\space - #\tab)) - then ; continuation - (setq state 2) - else (setq beginh next) - (setq state 3) - )) - (2 ; looking for first non blank in value - (if* (eq ch #\linefeed) - then ; empty continuation line, ignore - (incf next) - (go again) - elseif (not (member ch - (member ch - '(#\space - #\tab)))) - then ; begin value part - (setq beginv next) - (setq state 4))) - (3 ; reading the header - (if* (eq ch #\linefeed) - then ; bogus header line, ignore - (go again) - elseif (eq ch #\:) - then (setq header - (subseq text beginh next)) - (setq state 2))) - (4 ; looking for the end of the value - (if* (eq ch #\linefeed) - then (setq value - (subseq text beginv - (if* (eq #\return - (char text - (1- next))) - then (1- next) - else next))) - (incf next) - (return (if* header - then :start - else :continue)))))) - (incf next))))))) - - - + ;; find the next header line return + ;; :eof - no more + ;; :start - beginning of header value, header and + ;; value set + ;; :continue - continuation of previous header line + + + (let ((state 1) + beginv ; charpos beginning value + beginh ; charpos beginning header + ch + ) + (tagbody again + + (return-from next-header-line + + (loop ; for each character + + (if* (>= next end) + then (return :eof)) + + (setq ch (char text next)) + (if* (eq ch #\return) + thenret ; ignore return, (handle following linefeed) + else (case state + (1 ; no characters seen + (if* (eq ch #\linefeed) + then (incf next) + (return :eof) + elseif (member ch + '(#\space + #\tab)) + then ; continuation + (setq state 2) + else (setq beginh next) + (setq state 3) + )) + (2 ; looking for first non blank in value + (if* (eq ch #\linefeed) + then ; empty continuation line, ignore + (incf next) + (go again) + elseif (not (member ch + (member ch + '(#\space + #\tab)))) + then ; begin value part + (setq beginv next) + (setq state 4))) + (3 ; reading the header + (if* (eq ch #\linefeed) + then ; bogus header line, ignore + (go again) + elseif (eq ch #\:) + then (setq header + (subseq text beginh next)) + (setq state 2))) + (4 ; looking for the end of the value + (if* (eq ch #\linefeed) + then (setq value + (subseq text beginv + (if* (eq #\return + (char text + (1- next))) + then (1- next) + else next))) + (incf next) + (return (if* header + then :start + else :continue)))))) + (incf next))))))) + + + (loop ; for each header line - (setq header nil) - (if* (eq :eof (setq kind (next-header-line))) - then (return)) - (case kind - (:start (push (cons header value) headers)) - (:continue - (if* headers - then ; append to previous one - (setf (cdr (car headers)) - (concatenate 'string (cdr (car headers)) - " " - value))))))) + (setq header nil) + (if* (eq :eof (setq kind (next-header-line))) + then (return)) + (case kind + (:start (push (cons header value) headers)) + (:continue + (if* headers + then ; append to previous one + (setf (cdr (car headers)) + (concatenate 'string (cdr (car headers)) + " " + value))))))) (values headers - (subseq text next end)))) + (subseq text next end)))) (defun make-envelope-from-text (text) @@ -1317,7 +1317,7 @@ ;; a pop server ;; (let ((headers (parse-mail-header text))) - + (make-envelope :date (cdr (assoc "date" headers :test #'equalp)) :subject (cdr (assoc "subject" headers :test #'equalp)) @@ -1331,27 +1331,27 @@ :message-id (cdr (assoc "message-id" headers :test #'equalp)) ))) - - - - - + + + + + (defmethod get-and-parse-from-imap-server ((mb imap-mailbox)) ;; read the next line and parse it ;; ;; (multiple-value-bind (line count) (get-line-from-server mb) - (if* *debug-imap* + (if* *debug-imap* then (format t "from server: ") - (dotimes (i count)(write-char (schar line i))) - (terpri) - (force-output)) - + (dotimes (i count)(write-char (schar line i))) + (terpri) + (force-output)) + (parse-imap-response line count) )) @@ -1361,98 +1361,98 @@ ;; read the next line from the pop server ;; ;; return 3 values: - ;; :ok or :error + ;; :ok or :error ;; a list of rest of the tokens on the line ;; the whole line after the +ok or -err (multiple-value-bind (line count) (get-line-from-server mb) - - (if* *debug-imap* + + (if* *debug-imap* then (format t "from server: " count) - (dotimes (i count)(write-char (schar line i))) - (terpri)) - + (dotimes (i count)(write-char (schar line i))) + (terpri)) + (parse-pop-response line count))) - - + + ;; Parse and return the data from each line ;; values returned ;; tag -- either a string or the symbol :untagged ;; command -- a keyword symbol naming the command, like :ok ;; count -- a number which preceeded the command, or nil if -;; there wasn't a command +;; there wasn't a command ;; bracketted - a list of objects found in []'s after the command -;; or in ()'s after the command or sometimes just -;; out in the open after the command (like the search) +;; or in ()'s after the command or sometimes just +;; out in the open after the command (like the search) ;; comment -- the whole of the part after the command ;; (defun parse-imap-response (line end) (let (kind value next - tag count command extra-data - comment) - + tag count command extra-data + comment) + ;; get tag (multiple-value-setq (kind value next) (get-next-token line 0 end)) - + (case kind (:string (setq tag (if* (equal value "*") - then :untagged - else value))) + then :untagged + else value))) (t (po-error :unexpected - :format-control "Illegal tag on response: ~s" - :format-arguments (list (subseq line 0 count)) - :server-string (subseq line 0 end) - ))) - + :format-control "Illegal tag on response: ~s" + :format-arguments (list (subseq line 0 count)) + :server-string (subseq line 0 end) + ))) + ;; get command (multiple-value-setq (kind value next) (get-next-token line next end)) - + (tagbody again (case kind - (:number (setq count value) - (multiple-value-setq (kind value next) - (get-next-token line next end)) - (go again)) - (:string (setq command (kwd-intern value))) - (t (po-error :unexpected - :format-control "Illegal command on response: ~s" - :format-arguments (list (subseq line 0 count)) - :server-string (subseq line 0 end))))) + (:number (setq count value) + (multiple-value-setq (kind value next) + (get-next-token line next end)) + (go again)) + (:string (setq command (kwd-intern value))) + (t (po-error :unexpected + :format-control "Illegal command on response: ~s" + :format-arguments (list (subseq line 0 count)) + :server-string (subseq line 0 end))))) (setq comment (subseq line next end)) - + ;; now the part after the command... this gets tricky (loop (multiple-value-setq (kind value next) - (get-next-token line next end)) - + (get-next-token line next end)) + (case kind - ((:lbracket :lparen) - (multiple-value-setq (kind value next) - (get-next-sexpr line (1- next) end)) - (case kind - (:sexpr (push value extra-data)) - (t (po-error :syntax-error :format-control "bad sexpr form")))) - (:eof (return nil)) - ((:number :string :nil) (push value extra-data)) - (t ; should never happen - (return))) - + ((:lbracket :lparen) + (multiple-value-setq (kind value next) + (get-next-sexpr line (1- next) end)) + (case kind + (:sexpr (push value extra-data)) + (t (po-error :syntax-error :format-control "bad sexpr form")))) + (:eof (return nil)) + ((:number :string :nil) (push value extra-data)) + (t ; should never happen + (return))) + (if* (not (member command '(:list :search) :test #'eq)) - then ; only one item returned - (setq extra-data (car extra-data)) - (return))) + then ; only one item returned + (setq extra-data (car extra-data)) + (return))) (if* (member command '(:list :search) :test #'eq) then (setq extra-data (nreverse extra-data))) - - + + (values tag command count extra-data comment))) - + (defun get-next-sexpr (line start end) @@ -1461,374 +1461,374 @@ ;; kind -- :sexpr or :rparen or :rbracket ;; value - the sexpr value ;; next - next charpos to scan - ;; + ;; (let ( kind value next) (multiple-value-setq (kind value next) (get-next-token line start end)) - + (case kind ((:string :number :nil) (values :sexpr value next)) - (:eof (po-error :syntax-error - :format-control "eof inside sexpr")) + (:eof (po-error :syntax-error + :format-control "eof inside sexpr")) ((:lbracket :lparen) (let (res) - (loop - (multiple-value-setq (kind value next) - (get-next-sexpr line next end)) - (case kind - (:sexpr (push value res)) - ((:rparen :rbracket) - (return (values :sexpr (nreverse res) next))) - (t (po-error :syntax-error - :format-control "bad sexpression")))))) + (loop + (multiple-value-setq (kind value next) + (get-next-sexpr line next end)) + (case kind + (:sexpr (push value res)) + ((:rparen :rbracket) + (return (values :sexpr (nreverse res) next))) + (t (po-error :syntax-error + :format-control "bad sexpression")))))) ((:rbracket :rparen) (values kind nil next)) (t (po-error :syntax-error - :format-control "bad sexpression"))))) + :format-control "bad sexpression"))))) (defun parse-pop-response (line end) ;; return 3 values: - ;; :ok or :error + ;; :ok or :error ;; a list of rest of the tokens on the line, the tokens - ;; being either strings or integers + ;; being either strings or integers ;; the whole line after the +ok or -err ;; (let (res lineres result) (multiple-value-bind (kind value next) - (get-next-token line 0 end) - + (get-next-token line 0 end) + (case kind - (:string (setq result (if* (equal "+OK" value) - then :ok - else :error))) - (t (po-error :unexpected - :format-control "bad response from server" - :server-string (subseq line 0 end)))) - + (:string (setq result (if* (equal "+OK" value) + then :ok + else :error))) + (t (po-error :unexpected + :format-control "bad response from server" + :server-string (subseq line 0 end)))) + (setq lineres (subseq line next end)) (loop - (multiple-value-setq (kind value next) - (get-next-token line next end)) - - (case kind - (:eof (return)) - ((:string :number) (push value res)))) - + (multiple-value-setq (kind value next) + (get-next-token line next end)) + + (case kind + (:eof (return)) + ((:string :number) (push value res)))) + (values result (nreverse res) lineres)))) - - - - - - - - - - + + + + + + + + + + (defparameter *char-to-kind* (let ((arr (make-array 256 :initial-element nil))) - + (do ((i #.(char-code #\0) (1+ i))) - ((> i #.(char-code #\9))) - (setf (aref arr i) :number)) - + ((> i #.(char-code #\9))) + (setf (aref arr i) :number)) + (setf (aref arr #.(char-code #\space)) :space) (setf (aref arr #.(char-code #\tab)) :space) (setf (aref arr #.(char-code #\return)) :space) (setf (aref arr #.(char-code #\linefeed)) :space) - + (setf (aref arr #.(char-code #\[)) :lbracket) (setf (aref arr #.(char-code #\])) :rbracket) (setf (aref arr #.(char-code #\()) :lparen) (setf (aref arr #.(char-code #\))) :rparen) (setf (aref arr #.(char-code #\")) :dquote) - + (setf (aref arr #.(char-code #\^b)) :big-string) ; our own invention - + arr)) - - + + (defun get-next-token (line start end) ;; scan past whitespace for the next token ;; return three values: ;; kind: :string , :number, :eof, :lbracket, :rbracket, - ;; :lparen, :rparen + ;; :lparen, :rparen ;; value: the value, either a string or number or nil ;; next: the character pos to start scanning for the next token ;; (let (ch chkind colstart (count 0) (state :looking) - collector right-bracket-is-normal) - (loop + collector right-bracket-is-normal) + (loop ; pick up the next character (if* (>= start end) - then (if* (eq state :looking) - then (return (values :eof nil start)) - else (setq ch #\space)) - else (setq ch (schar line start))) - + then (if* (eq state :looking) + then (return (values :eof nil start)) + else (setq ch #\space)) + else (setq ch (schar line start))) + (setq chkind (aref *char-to-kind* (char-code ch))) - + (case state - (:looking - (case chkind - (:space nil) - (:number (setq state :number) - (setq colstart start) - (setq count (- (char-code ch) #.(char-code #\0)))) - ((:lbracket :lparen :rbracket :rparen) - (return (values chkind nil (1+ start)))) - (:dquote - (setq collector (make-array 10 - :element-type 'character - :adjustable t - :fill-pointer 0)) - (setq state :qstring)) - (:big-string - (setq colstart (1+ start)) - (setq state :big-string)) - (t (setq colstart start) - (setq state :literal)))) - (:number - (case chkind - ((:space :lbracket :lparen :rbracket :rparen - :dquote) ; end of number - (return (values :number count start))) - (:number ; more number - (setq count (+ (* count 10) - (- (char-code ch) #.(char-code #\0))))) - (t ; turn into an literal - (setq state :literal)))) - (:literal - (case chkind - ((:space :rbracket :lparen :rparen :dquote) ; end of literal - (if* (and (eq chkind :rbracket) - right-bracket-is-normal) - then nil ; don't stop now - else (let ((seq (subseq line colstart start))) - (if* (equal "NIL" seq) - then (return (values :nil - nil - start)) - else (return (values :string - seq - start)))))) - (t (if* (eq chkind :lbracket) - then ; imbedded left bracket so right bracket isn't - ; a break char - (setq right-bracket-is-normal t)) - nil))) - (:qstring - ;; quoted string - ; (format t "start is ~s kind is ~s~%" start chkind) - (case chkind - (:dquote - ;; end of string - (return (values :string collector (1+ start)))) - (t (if* (eq ch #\\) - then ; escaping the next character - (incf start) - (if* (>= start end) - then (po-error :unexpected - :format-control "eof in string returned")) - (setq ch (schar line start))) - (vector-push-extend ch collector) - - (if* (>= start end) - then ; we overran the end of the input - (po-error :unexpected - :format-control "eof in string returned"))))) - (:big-string - ;; super string... just a block of data - ; (format t "start is ~s kind is ~s~%" start chkind) - (case chkind - (:big-string - ;; end of string - (return (values :string - (subseq line colstart start) - (1+ start)))) - (t nil))) - - - ) - + (:looking + (case chkind + (:space nil) + (:number (setq state :number) + (setq colstart start) + (setq count (- (char-code ch) #.(char-code #\0)))) + ((:lbracket :lparen :rbracket :rparen) + (return (values chkind nil (1+ start)))) + (:dquote + (setq collector (make-array 10 + :element-type 'character + :adjustable t + :fill-pointer 0)) + (setq state :qstring)) + (:big-string + (setq colstart (1+ start)) + (setq state :big-string)) + (t (setq colstart start) + (setq state :literal)))) + (:number + (case chkind + ((:space :lbracket :lparen :rbracket :rparen + :dquote) ; end of number + (return (values :number count start))) + (:number ; more number + (setq count (+ (* count 10) + (- (char-code ch) #.(char-code #\0))))) + (t ; turn into an literal + (setq state :literal)))) + (:literal + (case chkind + ((:space :rbracket :lparen :rparen :dquote) ; end of literal + (if* (and (eq chkind :rbracket) + right-bracket-is-normal) + then nil ; don't stop now + else (let ((seq (subseq line colstart start))) + (if* (equal "NIL" seq) + then (return (values :nil + nil + start)) + else (return (values :string + seq + start)))))) + (t (if* (eq chkind :lbracket) + then ; imbedded left bracket so right bracket isn't + ; a break char + (setq right-bracket-is-normal t)) + nil))) + (:qstring + ;; quoted string + ; (format t "start is ~s kind is ~s~%" start chkind) + (case chkind + (:dquote + ;; end of string + (return (values :string collector (1+ start)))) + (t (if* (eq ch #\\) + then ; escaping the next character + (incf start) + (if* (>= start end) + then (po-error :unexpected + :format-control "eof in string returned")) + (setq ch (schar line start))) + (vector-push-extend ch collector) + + (if* (>= start end) + then ; we overran the end of the input + (po-error :unexpected + :format-control "eof in string returned"))))) + (:big-string + ;; super string... just a block of data + ; (format t "start is ~s kind is ~s~%" start chkind) + (case chkind + (:big-string + ;; end of string + (return (values :string + (subseq line colstart start) + (1+ start)))) + (t nil))) + + + ) + (incf start)))) - - + + ; this used to be exported from the excl package #+(and allegro (version>= 6 0)) (defvar *keyword-package* (find-package :keyword)) - - + + (defun kwd-intern (string) ;; convert the string to the current preferred case ;; and then intern (intern (case - #-allegro acl-compat.excl::*current-case-mode* - #+allegro excl::*current-case-mode* - ((:case-sensitive-lower - :case-insensitive-lower) (string-downcase string)) - (t (string-upcase string))) - *keyword-package*)) - - - - - - - - - - - - - - + #-allegro acl-compat.excl::*current-case-mode* + #+allegro excl::*current-case-mode* + ((:case-sensitive-lower + :case-insensitive-lower) (string-downcase string)) + (t (string-upcase string))) + *keyword-package*)) + + + + + + + + + + + + + + ;; low level i/o to server (defun get-line-from-server (mailbox) ;; Return two values: a buffer and a character count. ;; The character count includes up to but excluding the cr lf that ;; was read from the socket. - ;; + ;; (let* ((buff (get-line-buffer 0)) - (len (length buff)) - (i 0) - (p (post-office-socket mailbox)) - (ch nil) - (whole-count) - ) - - (handler-case - (flet ((grow-buffer (size) - (let ((newbuff (get-line-buffer size))) - (dotimes (j i) - (setf (schar newbuff j) (schar buff j))) - (free-line-buffer buff) - (setq buff newbuff) - (setq len (length buff))))) - - ;; increase the buffer to at least size - ;; this is somewhat complex to ensure that we aren't doing - ;; buffer allocation within the with-timeout form, since - ;; that could trigger a gc which could then cause the - ;; with-timeout form to expire. - (loop - - (if* whole-count - then ; we should now read in this may bytes and - ; append it to this buffer - (multiple-value-bind (ans this-count) - (get-block-of-data-from-server mailbox whole-count) - ; now put this data in the current buffer - (if* (> (+ i whole-count 5) len) - then ; grow the initial buffer - (grow-buffer (+ i whole-count 100))) - - (dotimes (ind this-count) - (setf (schar buff i) (schar ans ind)) - (incf i)) - (setf (schar buff i) #\^b) ; end of inset string - (incf i) - (free-line-buffer ans) - (setq whole-count nil) - ) - elseif ch - then ; we're growing the buffer holding the line data - (grow-buffer (+ len 200)) - (setf (schar buff i) ch) - (incf i)) - - - (block timeout - (with-timeout ((timeout mailbox) - (po-error :timeout - :format-control "imap server failed to respond")) - ;; read up to lf (lf most likely preceeded by cr) - (loop - (setq ch (read-char p)) - (if* (eq #\linefeed ch) - then ; end of line. Don't save the return - (if* (and (> i 0) - (eq (schar buff (1- i)) #\return)) - then ; remove #\return, replace with newline - (decf i) - (setf (schar buff i) #\newline) - ) - ;; must check for an extended return value which - ;; is indicated by a {nnn} at the end of the line - (block count-check - (let ((ind (1- i))) - (if* (and (>= i 0) (eq (schar buff ind) #\})) - then (let ((count 0) - (mult 1)) - (loop - (decf ind) - (if* (< ind 0) - then ; no of the form {nnn} - (return-from count-check)) - (setf ch (schar buff ind)) - (if* (eq ch #\{) - then ; must now read that many bytes - (setf (schar buff ind) #\^b) - (setq whole-count count) - (setq i (1+ ind)) - (return-from timeout) - elseif (<= #.(char-code #\0) - (char-code ch) - #.(char-code #\9)) - then ; is a digit - (setq count - (+ count - (* mult - (- (char-code ch) - #.(char-code #\0))))) - (setq mult (* 10 mult)) - else ; invalid form, get out - (return-from count-check))))))) - - - (return-from get-line-from-server - (values buff i)) - else ; save character - (if* (>= i len) - then ; need bigger buffer - (return)) - (setf (schar buff i) ch) - (incf i))))))) + (len (length buff)) + (i 0) + (p (post-office-socket mailbox)) + (ch nil) + (whole-count) + ) + + (handler-case + (flet ((grow-buffer (size) + (let ((newbuff (get-line-buffer size))) + (dotimes (j i) + (setf (schar newbuff j) (schar buff j))) + (free-line-buffer buff) + (setq buff newbuff) + (setq len (length buff))))) + + ;; increase the buffer to at least size + ;; this is somewhat complex to ensure that we aren't doing + ;; buffer allocation within the with-timeout form, since + ;; that could trigger a gc which could then cause the + ;; with-timeout form to expire. + (loop + + (if* whole-count + then ; we should now read in this may bytes and + ; append it to this buffer + (multiple-value-bind (ans this-count) + (get-block-of-data-from-server mailbox whole-count) + ; now put this data in the current buffer + (if* (> (+ i whole-count 5) len) + then ; grow the initial buffer + (grow-buffer (+ i whole-count 100))) + + (dotimes (ind this-count) + (setf (schar buff i) (schar ans ind)) + (incf i)) + (setf (schar buff i) #\^b) ; end of inset string + (incf i) + (free-line-buffer ans) + (setq whole-count nil) + ) + elseif ch + then ; we're growing the buffer holding the line data + (grow-buffer (+ len 200)) + (setf (schar buff i) ch) + (incf i)) + + + (block timeout + (with-timeout ((timeout mailbox) + (po-error :timeout + :format-control "imap server failed to respond")) + ;; read up to lf (lf most likely preceeded by cr) + (loop + (setq ch (read-char p)) + (if* (eq #\linefeed ch) + then ; end of line. Don't save the return + (if* (and (> i 0) + (eq (schar buff (1- i)) #\return)) + then ; remove #\return, replace with newline + (decf i) + (setf (schar buff i) #\newline) + ) + ;; must check for an extended return value which + ;; is indicated by a {nnn} at the end of the line + (block count-check + (let ((ind (1- i))) + (if* (and (>= i 0) (eq (schar buff ind) #\})) + then (let ((count 0) + (mult 1)) + (loop + (decf ind) + (if* (< ind 0) + then ; no of the form {nnn} + (return-from count-check)) + (setf ch (schar buff ind)) + (if* (eq ch #\{) + then ; must now read that many bytes + (setf (schar buff ind) #\^b) + (setq whole-count count) + (setq i (1+ ind)) + (return-from timeout) + elseif (<= #.(char-code #\0) + (char-code ch) + #.(char-code #\9)) + then ; is a digit + (setq count + (+ count + (* mult + (- (char-code ch) + #.(char-code #\0))))) + (setq mult (* 10 mult)) + else ; invalid form, get out + (return-from count-check))))))) + + + (return-from get-line-from-server + (values buff i)) + else ; save character + (if* (>= i len) + then ; need bigger buffer + (return)) + (setf (schar buff i) ch) + (incf i))))))) (error (con) - ;; most likely error is that the server went away - (ignore-errors (close p)) - (po-error :server-shutdown-connection - :format-control "condition signalled: ~a~%most likely server shut down the connection." - :format-arguments (list con))) + ;; most likely error is that the server went away + (ignore-errors (close p)) + (po-error :server-shutdown-connection + :format-control "condition signalled: ~a~%most likely server shut down the connection." + :format-arguments (list con))) ))) (defun get-block-of-data-from-server (mb count &key save-returns) ;; read count bytes from the server returning it in a line buffer object - ;; return as a second value the number of characters saved + ;; return as a second value the number of characters saved ;; (we drop #\return's so that lines are sepisarated by a #\newline ;; like lisp likes). ;; (let ((buff (get-line-buffer count)) - (p (post-office-socket mb)) - (ind 0)) + (p (post-office-socket mb)) + (ind 0)) (with-timeout ((timeout mb) - (po-error :timeout - :format-control "imap server timed out")) - + (po-error :timeout + :format-control "imap server timed out")) + (dotimes (i count) - (if* (eq #\return (setf (schar buff ind) (read-char p))) - then (if* save-returns then (incf ind)) ; drop #\returns - else (incf ind))) - - + (if* (eq #\return (setf (schar buff ind) (read-char p))) + then (if* save-returns then (incf ind)) ; drop #\returns + else (incf ind))) + + (values buff ind)))) - - + + ;;-- reusable line buffers (defvar *line-buffers* nil) @@ -1838,10 +1838,10 @@ (setq size (min size (1- array-total-size-limit))) (without-scheduling (dolist (buff *line-buffers* (make-string size)) - (if* (>= (length buff) size) - then ; use this one - (setq *line-buffers* (delete buff *line-buffers*)) - (return buff))))) + (if* (>= (length buff) size) + then ; use this one + (setq *line-buffers* (delete buff *line-buffers*)) + (return buff))))) (defun free-line-buffer (buff) @@ -1856,7 +1856,7 @@ (setf (schar new i) (schar old i)))) - + ;;;;;;; @@ -1870,14 +1870,14 @@ (decode-universal-time ut 0) (declare (ignore time-zone sec min hour day-of-week dsp time-zone)) (format nil "~d-~a-~d" - date - (svref - '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") - month - ) - year))) - - - - + date + (svref + '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + month + ) + year))) + + + +