imap.cl

;; -*- mode: common-lisp; package: net.post-office -*-
;;
;; imap.cl
;; imap and pop interface
;;
;; See the file LICENSE for the full license governing this code.

#+(version= 7 0)
(sys:defpatch "imap" 1
  "v1: fetch-letter-sequence support."
  :type :system
  :post-loadable t)

#+(version= 8 0)
(sys:defpatch "imap" 1
  "v1: fetch-letter-sequence support."
  :type :system
  :post-loadable t)

#+(version= 8 1)
(sys:defpatch "imap" 1
  "v1: Add ssl/tls support for both imap/pop connections."
  :type :system
  :post-loadable t)

;; Description:
;;- This code in this file obeys the Lisp Coding Standard found in
;;- https://www.franz.com/~jkf/coding_standards.html
;;-


(defpackage :net.post-office
  (:use :lisp :excl)
  (:export 
   #:address-name
   #:address-additional
   #:address-mailbox
   #:address-host
   
   #:alter-flags
   #:close-connection
   #:close-mailbox
   #:copy-to-mailbox
   #:create-mailbox
   #:delete-letter
   #:delete-mailbox
   
   #:envelope-date
   #:envelope-subject
   #:envelope-from
   #:envelope-sender
   #:envelope-reply-to
   #:envelope-to
   #:envelope-cc
   #:envelope-bcc
   #:envelope-in-reply-to
   #:envelope-message-id
   
   #:expunge-mailbox
   #:fetch-field
   #:fetch-letter
   #:fetch-letter-sequence
   #:end-of-letter-p
   #:with-fetch-letter-sequence
   #:fetch-parts
   #:*imap-version-number*
   #:make-envelope-from-text
   #:mailbox-flags      ; accessor
   #:mailbox-permanent-flags ; acc
   #:mailbox-list
   #:mailbox-list-flags
   #:mailbox-list-separator
   #:mailbox-list-name
   #:mailbox-message-count ; accessor
   #:mailbox-recent-messages ; ac
   #:mailbox-separator  ; accessor
   #:mailbox-uidvalidity
   #:mailbox-uidnext
   #:make-imap-connection
   #:make-pop-connection
   #:with-imap-connection
   #:with-pop-connection
   #:noop
   #:parse-mail-header
   #:top-lines	; pop only
   #:unique-id  ; pop only
   
   #:po-condition
   #:po-condition-identifier
   #:po-condition-server-string
   #:po-error
   
   #:rename-mailbox
   #:reset-mailbox
   #:search-mailbox
   #:select-mailbox
   
   )
  )

(in-package :net.post-office)

(provide :imap)

(defparameter *imap-version-number* '(:major 1 :minor 14)) ; major.minor

;; todo
;;  have the list of tags selected done on a per connection basis to
;;  eliminate any possible multithreading problems
;;
;;

(defvar *debug-imap* nil)





(defclass post-office ()
  ((socket :initarg :socket
	   :accessor post-office-socket)
   
   (host :initarg :host
	 :accessor  post-office-host
	 :initform nil)
   (user  :initarg :user
	  :accessor post-office-user
	  :initform nil)
   
   (state :accessor post-office-state
	  :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) 
  ))

(defclass imap-mailbox (post-office)
  ((mailbox-name   ; currently selected mailbox
    :accessor mailbox-name
    :initform nil)

   (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 
    :initform 0)
   
   (uidnext 
    :accessor mailbox-uidnext ;; predicted next uid
    :initform 0)
   
   (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
   
   ;;; state information for fetch-letter-sequence
   (fetch-letter-offset 
    :accessor fetch-letter-offset)
   (fetch-letter-number 
    :accessor fetch-letter-number)
   (fetch-letter-uid
    :accessor fetch-letter-uid)
   (fetch-letter-finished
    :accessor fetch-letter-finished)
   )
  )


(defclass pop-mailbox (post-office)
  ((message-count  ; how many in the mailbox
    :accessor mailbox-message-count
    :initform 0)
   (fetch-letter-state 
    :accessor state
    :initform :invalid)))
    



(defstruct (mailbox-list (:type list))
  ;; a list of these are returned by mailbox-list
  flags
  separator
  name)



(defstruct (envelope (:type list))
  ;; returned by fetch-letter as the value of the envelope property
  date
  subject
  from
  sender
  reply-to
  to
  cc
  bcc
  in-reply-to
  message-id)


(defstruct (address (:type list))
  name     ;; often the person's full name
  additional
  mailbox  ;; the login name
  host	   ;; the name of the machine 
  )



;--------------------------------
; conditions
;
; We define a set of conditions that are signalled due to events
; in the imap interface.
; Each condition has an indentifier which is a keyword.  That can
; be used in the handling code to identify the class of error.
; 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 
; something returned by the server.
; 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).
;	
; :unknown-ok   condition
;	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.
;
;  :error-response  error
;	the command failed.
;
;  :syntax-error   error
;	the data passed to a function in this interface was malformed
;
;  :unexpected    error
;	the server responded an unexpected way.
;
;  :server-shutdown-connection error
;	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
;
;  :response-too-large error
;	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 
    ;; keyword identifying the error (or :unknown)
    :reader po-condition-identifier	
    :initform :unknown
    :initarg :identifier
    )
   (server-string 
    ;; message from the imap server
    :reader po-condition-server-string
    :initform ""
    :initarg :server-string
    ))
  (:report
   (lambda (con stream)
     (with-slots (identifier server-string) con
       ;; a condition either has a server-string or it has a 
       ;; format-control string
       (format stream "Post Office condition: ~s~%" identifier)
       (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)))
       (if* server-string
	  then (format stream
		       "~&Message from server: ~s"
		       (string-left-trim " " server-string)))))))
	       
    

(define-condition po-error (po-condition error) 
  ;; used to denote things that should stop program flow
  ())



;; aignalling the conditions

(defun po-condition (identifier &key server-string format-control 
			  format-arguments)
  (signal (make-instance 'po-condition
	    :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)
  (error (make-instance 'po-error
	    :identifier identifier
	    :server-string server-string
	    :format-control format-control
	    :format-arguments format-arguments)))

			   

;----------------------------------------------






(defparameter *imap-tags* '("t01" "t02" "t03" "t04" "t05" "t06" "t07"))
(defvar *cur-imap-tags* nil)

(defvar *crlf*
    (let ((str (make-string 2)))
      (setf (aref str 0) #\return)
      (setf (aref str 1) #\linefeed)
      str))

;; returns values: socket starttls
;; server is a cons of the form:
;; (server-name &key (port 25) (ssl nil) (starttls nil) ...ssl-client-keywords...)
(defun connect-to-imap/pop-server (server-info server-type)
  (macrolet ((pop-keyword (k l) `(prog1 (getf ,l ,k) (remf ,l ,k)))
	     (server-port (ssl type) `(cond ((eq ,type :imap) (if ,ssl 993 143))
					    ((eq ,type :pop) (if ,ssl 995 110)))))
    (let* ((server (car server-info))
	   (ssl-args (cdr server-info))
	   ssl port starttls sock)
      (setq ssl (pop-keyword :ssl ssl-args))
      (setq port (or (pop-keyword :port ssl-args) (server-port ssl server-type)))
      (setq starttls (pop-keyword :starttls ssl-args))
      (setq sock (socket:make-socket :remote-host server
				     :remote-port port))
      (when ssl
	(setq sock (apply #'socket:make-ssl-client-stream sock ssl-args)))
      
      (values sock starttls))) )

(defun make-imap-connection (host &key (port 143) 
				       user 
				       password
				       (timeout 30))
  (multiple-value-bind (sock starttls)
      (if (consp host)
	  (connect-to-imap/pop-server host :imap)
	(socket:make-socket :remote-host host :remote-port port))
    (let ((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)
      (declare (ignorable cmd count extra))
      (if* (not (eq :untagged tag))
	 then  (po-error :error-response
			 :server-string comment)))
      
    ; check for starttls negotiation
    (when starttls
      (let (capabilities)
	(send-command-get-results
	 imap "CAPABILITY"
	 #'(lambda (mb cmd count extra comment)
	     (declare (ignorable mb cmd count extra))
	     (setq capabilities comment))
	 #'(lambda (mb cmd count extra comment)
	     (check-for-success mb cmd count extra comment
				"CAPABILITY")))
	(when (and capabilities (match-re "STARTTLS" capabilities :case-fold t
					  :return nil))
	  ;; negotiate starttls
	  (send-command-get-results imap "STARTTLS"
				    #'handle-untagged-response
				    #'(lambda (mb cmd count extra comment)
					(check-for-success mb cmd count extra comment
							   "STARTTLS")
					(setf (post-office-socket mb)
					  (socket:make-ssl-client-stream
					   (post-office-socket mb) :method :tlsv1)))))))

    ; 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")))
    
    ; find the separator character
    (let ((res (mailbox-list imap)))
      ;; 
      (let ((sep (cadr  (car res))))
	(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")))))
    (setf (post-office-socket mb) nil)
    (if* sock then (ignore-errors (close sock)))
    t))


(defmethod close-connection ((pb pop-mailbox))
  (let ((sock (post-office-socket pb)))
    (if* sock
       then (ignore-errors
	     (send-pop-command-get-results 
	      pb
	      "QUIT")))
    (setf (post-office-socket pb) nil)
    (if* sock then (ignore-errors (close sock)))
    t))



(defun make-pop-connection (host &key (port 110)
				      user
				      password
				      (timeout 30))
  (multiple-value-bind (sock starttls)
      (if (consp host)
	  (connect-to-imap/pop-server host :pop)
	(socket:make-socket :remote-host host :remote-port port))
    (let ((pop (make-instance 'pop-mailbox
		:socket sock
		:host   host
		:timeout timeout
		:state :unauthorized)))
    
    (multiple-value-bind (result)
	(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")))
      
    ; check for starttls negotiation
    (when starttls
      (let ((capabilities (send-pop-command-get-results pop "capa" t)))
	(when (and capabilities (match-re "STLS" capabilities :case-fold t
					  :return nil))
	  (send-pop-command-get-results pop "STLS")		   
	  (setf (post-office-socket pop) (socket:make-ssl-client-stream 
					  (post-office-socket pop) :method :tlsv1)))))
    
    ; 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)
  ;; 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*)
    (force-output (post-office-socket mb))
    
    (if* *debug-imap*
       then (format t
		    "~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))))))


(defun get-next-tag ()
  (let ((tag (pop *cur-imap-tags*)))
    (if*  tag
       thenret
       else (setq *cur-imap-tags* *imap-tags*)
	    (pop *cur-imap-tags*))))

(defun handle-untagged-response (mb command count extra comment)
  ;; default function to handle untagged responses, which are 
  ;; really just returning general state information about
  ;; the mailbox
  (case command
    (:exists (setf (mailbox-message-count mb) count))
    (:recent (setf (mailbox-recent-messages mb) count))
    (:flags  (setf (mailbox-flags mb) (kwd-intern-possible-list extra)))
    (: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"))
    (: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) 
		       (kwd-intern-possible-list (cadr extra)))
		else (po-condition :unknown-ok :server-string comment))))
    (t (po-condition :unknown-untagged :server-string comment)))
	     
  )


(defmethod begin-extended-results-sequence ((mb pop-mailbox))
  (setf (state mb) 1))

(defmethod get-extended-results-sequence ((mb pop-mailbox) buffer &key (start 0) (end (length buffer)))
  (declare (optimize (speed 3) (safety 1)))
  (let ((inpos start)
	(outpos start)
	(sock (post-office-socket mb))
	ch
	stop)
    (macrolet ((add-to-buffer () 
		 `(progn
		    (setf (schar buffer outpos) ch)
		    (incf outpos))))
      (while (and (< inpos end) (/= (state mb) 4))
	(setf stop (read-sequence buffer sock :start inpos :end end :partial-fill t))
	(while (< inpos stop)
	  (setf ch (schar buffer inpos))
	  (if* (eq ch #\return)
	     thenret			; ignore crs
	     else (ecase (state mb)
		    (1 (if* (eq ch #\.)	; at beginning of line
			  then (setf (state mb) 2)
			elseif (eq ch #\linefeed)
			  then 
			       (add-to-buffer) ; state stays at 1
			  else 
			       (setf (state mb) 3)
			       (add-to-buffer)))
		    (2			; seen first dot
		     (if* (eq ch #\linefeed)
			then		; end of results
			     (setf (state mb) 4)
			     (return) 
			else 
			     (setf (state mb) 3)
			     (add-to-buffer))) ; normal reading
		    (3			; middle of line
		     (if* (eq ch #\linefeed)
			then (setf (state mb) 1))
		     (add-to-buffer))))
	  (incf inpos))
	(setf inpos outpos))
      outpos)))

(defmacro end-of-extended-results-p (mb)
  `(= (state ,mb) 4))

(defmethod end-extended-results-sequence ((mb pop-mailbox))
  (declare (optimize (speed 3) (safety 1)))
  (let ((buffer (make-string 4096)))
    (until (end-of-extended-results-p mb)
      (get-extended-results-sequence mb buffer)))
  (setf (state mb) :invalid-state)
  t)

(defmacro with-extended-results-sequence ((mailbox) &body body)
  (let ((mb (gensym)))
    `(let ((,mb ,mailbox))
       (begin-extended-results-sequence ,mb)
       (unwind-protect
	   (progn
	     ,@body)
	 ;; cleanup
	 (end-extended-results-sequence ,mb)))))


  

(defun send-pop-command-get-results (pop command &optional extrap)
  (declare (optimize (speed 3) (safety 1)))
  ;; 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 
  ;;  of just a period)
  ;; 
  ;; if the pop server returns an error code we signal a lisp error.
  ;; otherwise
  ;; return
  ;;  extrap is nil -- return the list of tokens on the line after +ok
  ;;  extrap is true -- return the extra object (a big string)
  ;;
  (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))

  (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))

    (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)))
		   (buflen (length buf))
		   (pos 0))
	      (with-extended-results-sequence (pop)
		(until (end-of-extended-results-p pop)
		  (if* (>= pos buflen)
		     then    ;; grow buffer
			  (if* (>= buflen (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 (* buflen 2))))
			    (init-line-buffer new-buf buf)
			    (free-line-buffer buf)
			    (setq buf new-buf)
			    (setq buflen (length buf))))
		  (setf pos (get-extended-results-sequence pop buf :start pos :end buflen))))
	      (prog1 (subseq buf 0 pos)
		(free-line-buffer buf)))
       else parsed)))
  



(defun convert-flags-plist (plist)
  ;; 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)
    (if* (equalp "flags" (car xx))
       then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))))))


(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))))
  (setf (mailbox-name mb) name)
  t
  )


(defmethod fetch-letter ((mb imap-mailbox) number &key uid)
  ;; return the whole letter
  (fetch-field number "body[]"
	       (fetch-parts mb number "body[]" :uid uid)
	       :uid uid))


(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
				))

(defmethod begin-fetch-letter-sequence ((mb imap-mailbox) number &key uid)
  (setf (fetch-letter-offset mb) 0)
  (setf (fetch-letter-number mb) number)
  (setf (fetch-letter-uid mb) uid)
  (setf (fetch-letter-finished mb) nil))


(defmethod begin-fetch-letter-sequence ((mb pop-mailbox) number &key uid)
  (declare (ignore uid))
  (send-pop-command-get-results mb (format nil "RETR ~d" number))
  (begin-extended-results-sequence mb))

(defmethod fetch-letter-sequence ((mb imap-mailbox) buffer 
				  &key (start 0) (end (length buffer)))
  (let* ((num (fetch-letter-number mb))
	 (offset (fetch-letter-offset mb))
	 (uid (fetch-letter-uid mb))
	 (buflen (- end start))
	 (data (fetch-field num (format nil "body[]<~d>" offset) 
			    (fetch-parts mb num 
					 (format nil "body[]<~d.~d>" offset buflen)
					 :uid uid)
			    :uid uid))
	 (datalen (length data)))

    (setf (subseq buffer start end) data)
    
    (if* (and (> buflen 0) (= datalen 0))
       then (setf (fetch-letter-finished mb) t))
    
    (setf (fetch-letter-offset mb) (+ offset buflen))
    
    (+ start datalen)))
		       

(defmethod fetch-letter-sequence ((mb pop-mailbox) buffer &key (start 0) (end (length buffer)))
  (get-extended-results-sequence mb buffer :start start :end end))

(defmethod end-fetch-letter-sequence ((mb imap-mailbox))
  )

(defmethod end-fetch-letter-sequence ((mb pop-mailbox))
  (end-extended-results-sequence mb))

(defmethod end-of-letter-p ((mb imap-mailbox))
  (fetch-letter-finished mb))

(defmethod end-of-letter-p ((mb pop-mailbox))
  (end-of-extended-results-p mb))

(defmacro with-fetch-letter-sequence ((mailbox &rest args) &body body)
  (let ((mb (gensym)))
    `(let ((,mb ,mailbox))
       (begin-fetch-letter-sequence ,mb ,@args)
       (unwind-protect
	   (progn
	     ,@body)
	 ;; cleanup
	 (end-fetch-letter-sequence ,mb)))))
	    
(defmethod fetch-parts ((mb imap-mailbox) number parts &key uid)
  (let (res)
    (send-command-get-results 
     mb
     (format nil "~afetch ~a ~a"
	     (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)))
     #'(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))))
    res))

		      
(defun fetch-field (letter-number field-name info &key uid)
  ;; given the information from a fetch-letter, return the 
  ;; particular field for the particular letter
  ;;
  ;; info is as returned by fetch
  ;; field-name is a string, case doesn't matter.
  ;;
  (dolist (item info)
    ;; item is (messagenumber plist-info)
    ;; 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))))
    
      (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))))))))

	 

(defun internalize-flags (stuff)
  ;; 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 ; we can end up with sublists of forms if we 
	    ; do add-flags with a list of flags.  this seems like
	    ; a bug in the imap server.. but we have to deal with it
	      (setf (cadr xx) (kwd-intern-possible-list (cadr xx)))
	      (return)))
  
  stuff)

					


(defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid)
  ;; 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)))

(defmethod delete-letter ((pb pop-mailbox) messages  &key (expunge nil) uid)
  ;; 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))))
     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)))
  
  (dolist (message messages)
    (if* (numberp message)
       then (send-pop-command-get-results pb
					  (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)))
       else (po-error :syntax-error
		      :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"))))


(defmethod noop ((pb pop-mailbox))
  ;; send the stat command instead so we can update the message count
  (let ((res (send-pop-command-get-results pb "stat")))
      (setf (mailbox-message-count pb) (car res)))
  )


(defmethod unique-id ((pb pop-mailbox) &optional message)
  ;; if message is given, return the unique id of that
  ;; 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))
     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)))))

(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
					   )))
    res))
			     
			


(defmethod reset-mailbox ((pb pop-mailbox))
  ;; undo's deletes
  (send-pop-command-get-results pb "RSET")
  )
						   


(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)))

  
			    


(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")))
    
    ;; 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
				
  
    ))


(defmethod create-mailbox ((mb imap-mailbox) 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 "create ~s" mailbox-name)
			    #'handle-untagged-response
			    #'(lambda (mb command count extra comment)
				  (check-for-success 
				   mb command count extra 
				   comment "create")))
  t)


(defmethod delete-mailbox ((mb imap-mailbox) 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 "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"))))



(defmethod alter-flags ((mb imap-mailbox)
			messages &key (flags nil flags-p) 
				      add-flags remove-flags
				      silent uid)
  ;;
  ;; change the flags using the store command
  ;;
  (let (cmd val res)
    (if* flags-p
       then (setq cmd "flags" val flags)
     elseif add-flags
       then (setq cmd "+flags" val add-flags)
     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")))
    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)))))
				   
				   
				   
			      
					      
     
(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")))
    (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")))
  t)
  


(defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination
			    &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")))
  t)


;; search command

(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")))
    res))
    
		       
(defmacro defsearchop (name &rest operands)
  (if* (null operands)
     then `(setf (get ',name 'imap-search-no-args) t)
     else `(setf (get ',name 'imap-search-args) ',operands)))

(defsearchop :all)
(defsearchop :answered)
(defsearchop :bcc :str)
(defsearchop :before :date)
(defsearchop :body :str)
(defsearchop :cc :str)
(defsearchop :deleted)
(defsearchop :draft)
(defsearchop :flagged)
(defsearchop :from :str)
(defsearchop :header :str :str)
(defsearchop :keyword :flag)
(defsearchop :larger :number)
(defsearchop :new)
(defsearchop :old)
(defsearchop :on :date)
(defsearchop :recent)
(defsearchop :seen)
(defsearchop :sentbefore :date)
(defsearchop :senton :date)
(defsearchop :sentsince :date)
(defsearchop :since :date)
(defsearchop :smaller :number)
(defsearchop :subject :str)
(defsearchop :text :str)
(defsearchop :to :str)
(defsearchop :uid :messageset)
(defsearchop :unanswered)
(defsearchop :undeleted)
(defsearchop :undraft)
(defsearchop :unflagged)
(defsearchop :unkeyword :flag)
(defsearchop :unseen)



(defun build-search-string (search)
  ;; take the lisp search form and turn it into a string that can be
  ;; passed to imap

  (if* (null search)
     then ""
     else (let ((str (make-string-output-stream)))
	    (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))))
		  
		 ))))
    
    (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)))
     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))))))
     elseif (integerp search)
       then ;  a message number
	    (format str "~s" search)
       else (po-error :syntax-error
		      :format-control "Illegal form ~s in search string" 
		      :format-arguments (list search)))))





(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)
    (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)
					  (if* header
					     then ; header and no value
						  (setq value "")
						  (return :start))
					  (setq state 1)
					  (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
					  (setq state 1)
					  (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)))))))
    (values headers
	    (subseq text next end))))


(defun make-envelope-from-text (text)
  ;; given at least the headers part of a message return
  ;; an envelope structure containing the contents
  ;; This is useful for parsing the headers of things returned by
  ;; 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))
     :from     (cdr (assoc "from" headers :test #'equalp))
     :sender   (cdr (assoc "sender" headers :test #'equalp))
     :reply-to (cdr (assoc "reply-to" headers :test #'equalp))
     :to       (cdr (assoc "to" headers :test #'equalp))
     :cc       (cdr (assoc "cc" headers :test #'equalp))
     :bcc      (cdr (assoc "bcc" headers :test #'equalp))
     :in-reply-to (cdr (assoc "in-reply-to" headers :test #'equalp))
     :message-id (cdr (assoc "message-id" headers :test #'equalp))
     )))

		  
	      
				 
	      




    
(defmethod get-and-parse-from-imap-server ((mb imap-mailbox))
  ;; read the next line and parse it
  ;;
  ;;
  (multiple-value-bind (line count)
      (get-line-from-server mb)
    (if* *debug-imap* 
       then (format t "from server: ")
	    (dotimes (i count)(write-char (schar line i)))
	    (terpri)
	    (force-output))
    
    (parse-imap-response line count)
    ))



(defmethod get-and-parse-from-pop-server ((mb pop-mailbox))
  ;; read the next line from the pop server
  ;;
  ;; return 3 values:
  ;;   :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* 
       then (format t "from server: " count)
	    (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
;;  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)
;;  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)
    
    ;; 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)))
      (t (po-error :unexpected
		   :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)))))

    (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))
      
      (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)))
      
      (if* (not (member command '(:list :search) :test #'eq))
	 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)
  ;; read a whole s-expression
  ;; return 3 values
  ;;   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"))
      ((: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"))))))
      ((:rbracket :rparen)
       (values kind nil next))
      (t (po-error :syntax-error
		   :format-control "bad sexpression")))))


(defun parse-pop-response (line end)
  ;; return 3 values:
  ;;   :ok or :error 
  ;;   a list of rest of the tokens on the line, the tokens
  ;;	 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)
    
      (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))))
    
      (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))))
      
      (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))
      
      (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
  ;;  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 
      ; 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)))
      
      (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)))
	
		      
	)
      
      (incf start))))
	    
	    

;  this used to be exported from the excl package
#+(version>= 6 0)
(defvar *keyword-package* (find-package :keyword))

(defun kwd-intern-possible-list (form)
  (if* (null form)
     then nil
   elseif (atom form)
     then (kwd-intern form)
     else (mapcar #'kwd-intern-possible-list form)))

      
(defun kwd-intern (string)
  ;; convert the string to the current preferred case
  ;; and then intern
  (intern (case 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
	      (mp: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)))
      )))


(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 
  ;; (we drop #\return's so that lines are separated by a #\newline
  ;; like lisp likes).
  ;;
  (let ((buff (get-line-buffer count))
	(p (post-office-socket mb))
	(ind 0))
    (mp:with-timeout ((timeout mb)
		      (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)))
	
      
      (values buff ind))))
      
    
;;-- reusable line buffers

(defvar *line-buffers* nil)

#+(version>= 8 1)
(defvar *line-buffers-lock* (make-basic-lock :name "line-buffers"))

(defmacro with-locked-line-buffers (&rest body)
#+(version>= 8 1)
  `(with-locked-structure (*line-buffers-lock*
			   :non-smp :without-scheduling)
     ,@body)
#-(version>= 8 1)
  `(sys::without-scheduling ,@body)
  )

(defun get-line-buffer (size)
  ;; get a buffer of at least size bytes
  (setq size (min size (1- array-total-size-limit)))
  (let ((found 
	 (with-locked-line-buffers
	   (dolist (buff *line-buffers*)
	     (if* (>= (length buff) size)
		then ;; use this one
		     (setq *line-buffers* (delete buff *line-buffers*))
		     (return buff))))))
    (or found  (make-string size))))

(defun free-line-buffer (buff)
  (with-locked-line-buffers
    (push buff *line-buffers*)))

(defun init-line-buffer (new old)
  ;; copy old into new
  (declare (optimize (speed 3)))
  (dotimes (i (length old))
    (declare (fixnum i))
    (setf (schar new i) (schar old i))))

  

  ;;;;;;;

; date functions

(defun universal-time-to-rfc822-date (ut)
  ;; convert a lisp universal time to rfc 822 date
  ;;
  (multiple-value-bind
      (sec min hour date month year day-of-week dsp time-zone)
      (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)))
  
			  


;; utility

(defmacro with-imap-connection ((mb &rest options) &body body)
  `(let ((,mb (make-imap-connection ,@options)))
     (unwind-protect
	 (progn
	   ,@body)
       (close-connection ,mb))))


(defmacro with-pop-connection ((mb &rest options) &body body)
  `(let ((,mb (make-pop-connection ,@options)))
     (unwind-protect
	 (progn
	   ,@body)
       (close-connection ,mb))))