imap.cl

   1 ;; -*- mode: common-lisp; package: net.post-office -*-
   2 ;;
   3 ;; imap.cl
   4 ;; imap and pop interface
   5 ;;
   6 ;; copyright (c) 1999 Franz Inc, Berkeley, CA  - All rights reserved.
   7 ;;
   8 ;; The software, data and information contained herein are proprietary
   9 ;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
  10 ;; given in confidence by Franz, Inc. pursuant to a written license
  11 ;; agreement, and may be stored and used only in accordance with the terms
  12 ;; of such license.
  13 ;;
  14 ;; Restricted Rights Legend
  15 ;; ------------------------
  16 ;; Use, duplication, and disclosure of the software, data and information
  17 ;; contained herein by any agency, department or entity of the U.S.
  18 ;; Government are subject to restrictions of Restricted Rights for
  19 ;; Commercial Software developed at private expense as specified in
  20 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
  21 ;;
  22 ;; $Id: imap.cl,v 1.1 2002/10/09 14:26:11 kevin Exp $
  23
  24 ;; Description:
  25 ;;
  26 ;;
  27 ;;- This code in this file obeys the Lisp Coding Standard found in
  28 ;;- http://www.franz.com/~jkf/coding_standards.html
  29 ;;-
  30
  31
  32 (defpackage :net.post-office
  33   (:use :lisp :excl)
  34   (:export
  35    #:address-name
  36    #:address-additional
  37    #:address-mailbox
  38    #:address-host
  39
  40    #:alter-flags
  41    #:close-connection
  42    #:close-mailbox
  43    #:copy-to-mailbox
  44    #:create-mailbox
  45    #:delete-letter
  46    #:delete-mailbox
  47
  48    #:envelope-date
  49    #:envelope-subject
  50    #:envelope-from
  51    #:envelope-sender
  52    #:envelope-reply-to
  53    #:envelope-to
  54    #:envelope-cc
  55    #:envelope-bcc
  56    #:envelope-in-reply-to
  57    #:envelope-message-id
  58
  59    #:expunge-mailbox
  60    #:fetch-field
  61    #:fetch-letter
  62    #:fetch-parts
  63    #:*imap-version-number*
  64    #:make-envelope-from-text
  65    #:mailbox-flags      ; accessor
  66    #:mailbox-permanent-flags ; acc
  67    #:mailbox-list
  68    #:mailbox-list-flags
  69    #:mailbox-list-separator
  70    #:mailbox-list-name
  71    #:mailbox-message-count ; accessor
  72    #:mailbox-recent-messages ; ac
  73    #:mailbox-separator  ; accessor
  74    #:mailbox-uidvalidity
  75    #:make-imap-connection
  76    #:make-pop-connection
  77    #:noop
  78    #:parse-mail-header
  79    #:top-lines  ; pop only
  80    #:unique-id  ; pop only
  81
  82    #:po-condition
  83    #:po-condition-identifier
  84    #:po-condition-server-string
  85    #:po-error
  86
  87    #:rename-mailbox
  88    #:search-mailbox
  89    #:select-mailbox
  90
  91    )
  92   )
  93
  94 (in-package :net.post-office)
  95
  96 (provide :imap)
  97
  98 (defparameter *imap-version-number* '(:major 1 :minor 8)) ; major.minor
  99
 100 ;; todo
 101 ;;  have the list of tags selected done on a per connection basis to
 102 ;;  eliminate any possible multithreading problems
 103 ;;
 104 ;;
 105
 106 (defvar *debug-imap* nil)
 107
 108
 109
 110
 111
 112 (defclass post-office ()
 113   ((socket :initarg :socket
 114            :accessor post-office-socket)
 115
 116    (host :initarg :host
 117          :accessor  post-office-host
 118          :initform nil)
 119    (user  :initarg :user
 120           :accessor post-office-user
 121           :initform nil)
 122
 123    (state :accessor post-office-state
 124           :initarg :state
 125           :initform :unconnected)
 126
 127    (timeout
 128     ;; time to wait for network activity for actions that should
 129     ;; happen very quickly when things are operating normally
 130     :initarg :timeout
 131     :initform 60
 132     :accessor timeout)
 133   ))
 134
 135 (defclass imap-mailbox (post-office)
 136   ((mailbox-name   ; currently selected mailbox
 137     :accessor mailbox-name
 138     :initform nil)
 139
 140    (separator
 141     ;; string that separates mailbox names in the hierarchy
 142     :accessor mailbox-separator
 143     :initform "")
 144
 145    ;;; these slots hold information about the currently selected mailbox:
 146
 147     (message-count  ; how many in the mailbox
 148     :accessor mailbox-message-count
 149     :initform 0)
 150
 151    (recent-messages ; how many messages since we last checked
 152     :accessor mailbox-recent-messages
 153     :initform 0)
 154
 155    (uidvalidity  ; used to denote messages uniquely
 156     :accessor mailbox-uidvalidity
 157     :initform 0)
 158
 159    (uidnext
 160     :accessor mailbox-uidnext ;; predicted next uid
 161     :initform 0)
 162
 163    (flags       ; list of flags that can be stored in a message
 164     :accessor mailbox-flags
 165     :initform nil)
 166
 167    (permanent-flags  ; list of flags that be stored permanently
 168     :accessor mailbox-permanent-flags
 169     :initform nil)
 170
 171    (first-unseen   ; number of the first unseen message
 172     :accessor first-unseen
 173     :initform 0)
 174
 175    ;;; end list of values for the currently selected mailbox
 176    )
 177   )
 178
 179
 180 (defclass pop-mailbox (post-office)
 181   ((message-count  ; how many in the mailbox
 182     :accessor mailbox-message-count
 183     :initform 0)))
 184
 185
 186
 187 (defstruct (mailbox-list (:type list))
 188   ;; a list of these are returned by mailbox-list
 189   flags
 190   separator
 191   name)
 192
 193
 194
 195 (defstruct (envelope (:type list))
 196   ;; returned by fetch-letter as the value of the envelope property
 197   date
 198   subject
 199   from
 200   sender
 201   reply-to
 202   to
 203   cc
 204   bcc
 205   in-reply-to
 206   message-id)
 207
 208
 209 (defstruct (address (:type list))
 210   name     ;; often the person's full name
 211   additional
 212   mailbox  ;; the login name
 213   host     ;; the name of the machine
 214   )
 215
 216
 217
 218 ;--------------------------------
 219 ; conditions
 220 ;
 221 ; We define a set of conditions that are signalled due to events
 222 ; in the imap interface.
 223 ; Each condition has an indentifier which is a keyword.  That can
 224 ; be used in the handling code to identify the class of error.
 225 ; All our conditions are po-condition or po-error (which is a subclass of
 226 ; po-condition).
 227 ;
 228 ; A condition will have a server-string value if it as initiated by
 229 ; something returned by the server.
 230 ; A condition will have a format-control value if we want to display
 231 ; something we generated in response to
 232 ;
 233 ;
 234 ;
 235 ;; identifiers used in conditions/errors
 236
 237 ; :problem  condition
 238 ;       the server responded with 'no' followed by an explanation.
 239 ;       this mean that something unusual happend and doesn't necessarily
 240 ;       mean that the command has completely failed (but it might).
 241 ;
 242 ; :unknown-ok   condition
 243 ;       the server responded with an 'ok' followed by something
 244 ;       we don't recognize.  It's probably safe to ignore this.
 245 ;
 246 ;  :unknown-untagged condition
 247 ;       the server responded with some untagged command we don't
 248 ;       recognize.  it's probaby ok to ignore this.
 249 ;
 250 ;  :error-response  error
 251 ;       the command failed.
 252 ;
 253 ;  :syntax-error   error
 254 ;       the data passed to a function in this interface was malformed
 255 ;
 256 ;  :unexpected    error
 257 ;       the server responded an unexpected way.
 258 ;
 259 ;  :server-shutdown-connection error
 260 ;       the server has shut down the connection, don't attempt to
 261 ;       send any more commands to this connection, or even close it.
 262 ;
 263 ;  :timeout  error
 264 ;       server failed to respond within the timeout period
 265 ;
 266 ;  :response-too-large error
 267 ;       contents of a response is too large to store in a Lisp array.
 268
 269
 270 ;; conditions
 271 (define-condition po-condition ()
 272   ;; used to notify user of things that shouldn't necessarily stop
 273   ;; program flow
 274   ((identifier
 275     ;; keyword identifying the error (or :unknown)
 276     :reader po-condition-identifier
 277     :initform :unknown
 278     :initarg :identifier
 279     )
 280    (server-string
 281     ;; message from the imap server
 282     :reader po-condition-server-string
 283     :initform ""
 284     :initarg :server-string
 285     ))
 286   (:report
 287    (lambda (con stream)
 288      (with-slots (identifier server-string) con
 289        ;; a condition either has a server-string or it has a
 290        ;; format-control string
 291        (format stream "Post Office condition: ~s~%" identifier)
 292        (if* (and (slot-boundp con 'excl::format-control)
 293                  (excl::simple-condition-format-control con))
 294           then (apply #'format stream
 295                       (excl::simple-condition-format-control con)
 296                       (excl::simple-condition-format-arguments con)))
 297        (if* server-string
 298           then (format stream
 299                        "~&Message from server: ~s"
 300                        (string-left-trim " " server-string)))))))
 301
 302
 303
 304 (define-condition po-error (po-condition error)
 305   ;; used to denote things that should stop program flow
 306   ())
 307
 308
 309
 310 ;; aignalling the conditions
 311
 312 (defun po-condition (identifier &key server-string format-control
 313                           format-arguments)
 314   (signal (make-instance 'po-condition
 315             :identifier identifier
 316             :server-string server-string
 317             :format-control format-control
 318             :format-arguments format-arguments
 319             )))
 320
 321 (defun po-error (identifier &key server-string
 322                       format-control format-arguments)
 323   (error (make-instance 'po-error
 324             :identifier identifier
 325             :server-string server-string
 326             :format-control format-control
 327             :format-arguments format-arguments)))
 328
 329
 330
 331 ;----------------------------------------------
 332
 333
 334
 335
 336
 337
 338 (defparameter *imap-tags* '("t01" "t02" "t03" "t04" "t05" "t06" "t07"))
 339 (defvar *cur-imap-tags* nil)
 340
 341 (defvar *crlf*
 342     (let ((str (make-string 2)))
 343       (setf (aref str 0) #\return)
 344       (setf (aref str 1) #\linefeed)
 345       str))
 346
 347 (defun make-imap-connection (host &key (port 143)
 348                                        user
 349                                        password
 350                                        (timeout 30))
 351   (let* ((sock (socket:make-socket :remote-host host
 352                                    :remote-port port))
 353          (imap (make-instance 'imap-mailbox
 354                  :socket sock
 355                  :host   host
 356                  :timeout timeout
 357                  :state :unauthorized)))
 358
 359     (multiple-value-bind (tag cmd count extra comment)
 360         (get-and-parse-from-imap-server imap)
 361       (declare (ignore cmd count extra))
 362       (if* (not (eq :untagged tag))
 363          then  (po-error :error-response
 364                          :server-string comment)))
 365
 366     ; now login
 367     (send-command-get-results imap
 368                               (format nil "login ~a ~a" user password)
 369                               #'handle-untagged-response
 370                               #'(lambda (mb command count extra comment)
 371                                   (check-for-success mb command count extra
 372                                                      comment
 373                                                      "login")))
 374
 375     ; find the separator character
 376     (let ((res (mailbox-list imap)))
 377       ;;
 378       (let ((sep (cadr  (car res))))
 379         (if* sep
 380            then (setf (mailbox-separator imap) sep))))
 381
 382
 383
 384     imap))
 385
 386
 387 (defmethod close-connection ((mb imap-mailbox))
 388
 389   (let ((sock (post-office-socket mb)))
 390     (if* sock
 391        then (ignore-errors
 392              (send-command-get-results
 393               mb
 394               "logout"
 395               ; don't want to get confused by untagged
 396               ; bye command, which is expected here
 397               #'(lambda (mb command count extra)
 398                   (declare (ignore mb command count extra))
 399                   nil)
 400               #'(lambda (mb command count extra comment)
 401                   (check-for-success mb command count extra
 402                                      comment
 403                                      "logout")))))
 404     (setf (post-office-socket mb) nil)
 405     (if* sock then (ignore-errors (close sock)))
 406     t))
 407
 408
 409 (defmethod close-connection ((pb pop-mailbox))
 410   (let ((sock (post-office-socket pb)))
 411     (if* sock
 412        then (ignore-errors
 413              (send-pop-command-get-results
 414               pb
 415               "QUIT")))
 416     (setf (post-office-socket pb) nil)
 417     (if* sock then (ignore-errors (close sock)))
 418     t))
 419
 420
 421
 422 (defun make-pop-connection (host &key (port 110)
 423                                       user
 424                                       password
 425                                       (timeout 30))
 426   (let* ((sock (socket:make-socket :remote-host host
 427                                    :remote-port port))
 428          (pop (make-instance 'pop-mailbox
 429                 :socket sock
 430                 :host   host
 431                 :timeout timeout
 432                 :state :unauthorized)))
 433
 434     (multiple-value-bind (result)
 435         (get-and-parse-from-pop-server pop)
 436       (if* (not (eq :ok result))
 437          then  (po-error :error-response
 438                          :format-control
 439                          "unexpected line from server after connect")))
 440
 441     ; now login
 442     (send-pop-command-get-results pop (format nil "user ~a" user))
 443     (send-pop-command-get-results pop (format nil "pass ~a" password))
 444
 445     (let ((res (send-pop-command-get-results pop "stat")))
 446       (setf (mailbox-message-count pop) (car res)))
 447
 448
 449
 450     pop))
 451
 452
 453 (defmethod send-command-get-results ((mb imap-mailbox)
 454                                      command untagged-handler tagged-handler)
 455   ;; send a command and retrieve results until we get the tagged
 456   ;; response for the command we sent
 457   ;;
 458   (let ((tag (get-next-tag)))
 459     (format (post-office-socket mb)
 460             "~a ~a~a" tag command *crlf*)
 461     (force-output (post-office-socket mb))
 462
 463     (if* *debug-imap*
 464        then (format t
 465                     "~a ~a~a" tag command *crlf*)
 466             (force-output))
 467     (loop
 468       (multiple-value-bind (got-tag cmd count extra comment)
 469           (get-and-parse-from-imap-server mb)
 470         (if* (eq got-tag :untagged)
 471            then (funcall untagged-handler mb cmd count extra comment)
 472          elseif (equal tag got-tag)
 473            then (funcall tagged-handler mb cmd count extra comment)
 474                 (return)
 475            else (po-error :error-response
 476                           :format-control "received tag ~s out of order"
 477                           :format-arguments (list got-tag)
 478                           :server-string comment))))))
 479
 480
 481 (defun get-next-tag ()
 482   (let ((tag (pop *cur-imap-tags*)))
 483     (if*  tag
 484        thenret
 485        else (setq *cur-imap-tags* *imap-tags*)
 486             (pop *cur-imap-tags*))))
 487
 488 (defun handle-untagged-response (mb command count extra comment)
 489   ;; default function to handle untagged responses, which are
 490   ;; really just returning general state information about
 491   ;; the mailbox
 492   (case command
 493     (:exists (setf (mailbox-message-count mb) count))
 494     (:recent (setf (mailbox-recent-messages mb) count))
 495     (:flags  (setf (mailbox-flags mb) (mapcar #'kwd-intern extra)))
 496     (:bye ; occurs when connection times out or mailbox lock is stolen
 497      (ignore-errors (close (post-office-socket mb)))
 498      (po-error :server-shutdown-connection
 499                  :server-string "server shut down the connection"))
 500     (:no ; used when grabbing a lock from another process
 501      (po-condition :problem :server-string comment))
 502     (:ok ; a whole variety of things
 503      (if* extra
 504         then (if* (equalp (car extra) "unseen")
 505                 then (setf (first-unseen mb) (cadr extra))
 506               elseif (equalp (car extra) "uidvalidity")
 507                 then (setf (mailbox-uidvalidity mb) (cadr extra))
 508               elseif (equalp (car extra) "uidnext")
 509                 then (setf (mailbox-uidnext mb) (cadr extra))
 510               elseif (equalp (car extra) "permanentflags")
 511                 then (setf (mailbox-permanent-flags mb)
 512                        (mapcar #'kwd-intern (cadr extra)))
 513                 else (po-condition :unknown-ok :server-string comment))))
 514     (t (po-condition :unknown-untagged :server-string comment)))
 515
 516   )
 517
 518
 519
 520 (defun send-pop-command-get-results (pop command &optional extrap)
 521   ;; send the given command to the pop server
 522   ;; if extrap is true and if the response is +ok, then data
 523   ;;  will follow the command (up to and excluding the first line consisting
 524   ;;  of just a period)
 525   ;;
 526   ;; if the pop server returns an error code we signal a lisp error.
 527   ;; otherwise
 528   ;; return
 529   ;;  extrap is nil -- return the list of tokens on the line after +ok
 530   ;;  extrap is true -- return the extra object (a big string)
 531   ;;
 532   (format (post-office-socket pop) "~a~a" command *crlf*)
 533   (force-output (post-office-socket pop))
 534
 535   (if* *debug-imap*
 536      then (format t "~a~a" command *crlf*)
 537           (force-output t))
 538
 539   (multiple-value-bind (result parsed line)
 540       (get-and-parse-from-pop-server pop)
 541     (if* (not (eq result :ok))
 542        then (po-error :error-response
 543                       :server-string line))
 544
 545     (if* extrap
 546        then ;; get the rest of the data
 547             ;; many but not all pop servers return the size of the data
 548             ;; after the +ok, so we use that to initially size the
 549             ;; retreival buffer.
 550             (let ((buf (get-line-buffer (+ (if* (fixnump (car parsed))
 551                                               then (car parsed)
 552                                               else 2048 ; reasonable size
 553                                                    )
 554                                            50)))
 555                   (pos 0)
 556                   ; states
 557                   ;  1 - after lf
 558                   ;  2 - seen dot at beginning of line
 559                   ;  3 - seen regular char on line
 560                   (state 1)
 561                   (sock (post-office-socket pop)))
 562               (flet ((add-to-buffer (ch)
 563                        (if* (>= pos (length buf))
 564                           then ; grow buffer
 565                                (if* (>= (length buf)
 566                                         (1- array-total-size-limit))
 567                                   then ; can't grow it any further
 568                                        (po-error
 569                                         :response-too-large
 570                                         :format-control
 571                                         "response from mail server is too large to hold in a lisp array"))
 572                                (let ((new-buf (get-line-buffer
 573                                                (* (length buf) 2))))
 574                                  (init-line-buffer new-buf buf)
 575                                  (free-line-buffer buf)
 576                                  (setq buf new-buf)))
 577                        (setf (schar buf pos) ch)
 578                        (incf pos)))
 579                 (loop
 580                   (let ((ch (read-char sock nil nil)))
 581                     (if* (null ch)
 582                        then (po-error :unexpected
 583                                       :format-control "premature end of file from server"))
 584                     (if* (eq ch #\return)
 585                        thenret ; ignore crs
 586                        else (case state
 587                               (1 (if* (eq ch #\.)
 588                                     then (setq state 2)
 589                                   elseif (eq ch #\linefeed)
 590                                     then (add-to-buffer ch)
 591                                          ; state stays at 1
 592                                     else (add-to-buffer ch)
 593                                          (setq state 3)))
 594                               (2 ; seen first dot
 595                                (if* (eq ch #\linefeed)
 596                                   then ; end of message
 597                                        (return)
 598                                   else (add-to-buffer ch)
 599                                        (setq state 3)))
 600                               (3 ; normal reading
 601                                (add-to-buffer ch)
 602                                (if* (eq ch #\linefeed)
 603                                   then (setq state 1))))))))
 604               (prog1 (subseq buf 0 pos)
 605                 (free-line-buffer buf)))
 606        else parsed)))
 607
 608
 609
 610
 611 (defun convert-flags-plist (plist)
 612   ;; scan the plist looking for "flags" indicators and
 613   ;; turn value into a list of symbols rather than strings
 614   (do ((xx plist (cddr xx)))
 615       ((null xx) plist)
 616     (if* (equalp "flags" (car xx))
 617        then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))))))
 618
 619
 620 (defmethod select-mailbox ((mb imap-mailbox) name)
 621   ;; select the given mailbox
 622   (send-command-get-results mb
 623                             (format nil "select ~a" name)
 624                             #'handle-untagged-response
 625                             #'(lambda (mb command count extra comment)
 626                                 (declare (ignore mb count extra))
 627                                 (if* (not (eq command :ok))
 628                                    then (po-error
 629                                          :problem
 630                                          :format-control
 631                                          "imap mailbox select failed"
 632                                          :server-string comment))))
 633   (setf (mailbox-name mb) name)
 634   t
 635   )
 636
 637
 638 (defmethod fetch-letter ((mb imap-mailbox) number &key uid)
 639   ;; return the whole letter
 640   (fetch-field number "body[]"
 641                (fetch-parts mb number "body[]" :uid uid)
 642                :uid uid))
 643
 644
 645 (defmethod fetch-letter ((pb pop-mailbox) number &key uid)
 646   (declare (ignore uid))
 647   (send-pop-command-get-results pb
 648                                 (format nil "RETR ~d" number)
 649                                 t ; extra stuff
 650                                 ))
 651
 652 (defmethod fetch-parts ((mb imap-mailbox) number parts &key uid)
 653   (let (res)
 654     (send-command-get-results
 655      mb
 656      (format nil "~afetch ~a ~a"
 657              (if* uid then "uid " else "")
 658              (message-set-string number)
 659              (or parts "body[]")
 660              )
 661      #'(lambda (mb command count extra comment)
 662          (if* (eq command :fetch)
 663             then (push (list count (internalize-flags extra)) res)
 664             else (handle-untagged-response
 665                   mb command count extra comment)))
 666      #'(lambda (mb command count extra comment)
 667          (declare (ignore mb count extra))
 668          (if* (not (eq command :ok))
 669             then (po-error :problem
 670                            :format-control "imap mailbox fetch failed"
 671                            :server-string comment))))
 672     res))
 673
 674
 675 (defun fetch-field (letter-number field-name info &key uid)
 676   ;; given the information from a fetch-letter, return the
 677   ;; particular field for the particular letter
 678   ;;
 679   ;; info is as returned by fetch
 680   ;; field-name is a string, case doesn't matter.
 681   ;;
 682   (dolist (item info)
 683     ;; item is (messagenumber plist-info)
 684     ;; the same messagenumber may appear in multiple items
 685     (let (use-this)
 686       (if* uid
 687          then ; uid appears as a property in the value, not
 688               ; as the top level message sequence number
 689               (do ((xx (cadr item) (cddr xx)))
 690                   ((null xx))
 691                 (if* (equalp "uid" (car xx))
 692                    then (if* (eql letter-number (cadr xx))
 693                            then (return (setq use-this t))
 694                            else (return))))
 695          else ; just a message sequence number
 696               (setq use-this (eql letter-number (car item))))
 697
 698       (if* use-this
 699          then (do ((xx (cadr item) (cddr xx)))
 700                   ((null xx))
 701                 (if* (equalp field-name (car xx))
 702                    then (return-from fetch-field (cadr xx))))))))
 703
 704
 705
 706 (defun internalize-flags (stuff)
 707   ;; given a plist like object, look for items labelled "flags" and
 708   ;; convert the contents to internal flags objects
 709   (do ((xx stuff (cddr xx)))
 710       ((null xx))
 711     (if* (equalp (car xx) "flags")
 712        then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx)))
 713             (return)))
 714
 715   stuff)
 716
 717
 718
 719
 720 (defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid)
 721   ;; delete all the mesasges and do the expunge to make
 722   ;; it permanent if expunge is true
 723   (alter-flags mb messages :add-flags :\\deleted :uid uid)
 724   (if* expunge then (expunge-mailbox mb)))
 725
 726 (defmethod delete-letter ((pb pop-mailbox) messages  &key (expunge nil) uid)
 727   ;; delete all the messages.   We can't expunge without quitting so
 728   ;; we don't expunge
 729   (declare (ignore expunge uid))
 730
 731   (if* (or (numberp messages)
 732            (and (consp messages) (eq :seq (car messages))))
 733      then (setq messages (list messages)))
 734
 735   (if* (not (consp messages))
 736      then (po-error :syntax-error
 737                     :format-control "expect a mesage number or list of messages, not ~s"
 738                  :format-arguments (list messages)))
 739
 740   (dolist (message messages)
 741     (if* (numberp message)
 742        then (send-pop-command-get-results pb
 743                                           (format nil "DELE ~d" message))
 744      elseif (and (consp message) (eq :seq (car message)))
 745        then (do ((start (cadr message) (1+ start))
 746                  (end (caddr message)))
 747                 ((> start end))
 748               (send-pop-command-get-results pb
 749                                             (format nil "DELE ~d" start)))
 750        else (po-error :syntax-error
 751                       :format-control "bad message number ~s"
 752                       :format-arguments (list message)))))
 753
 754
 755
 756
 757
 758 (defmethod noop ((mb imap-mailbox))
 759   ;; just poke the server... keeping it awake and checking for
 760   ;; new letters
 761   (send-command-get-results mb
 762                             "noop"
 763                             #'handle-untagged-response
 764                             #'(lambda (mb command count extra comment)
 765                                 (check-for-success
 766                                  mb command count extra
 767                                  comment
 768                                  "noop"))))
 769
 770
 771 (defmethod noop ((pb pop-mailbox))
 772   ;; send the stat command instead so we can update the message count
 773   (let ((res (send-pop-command-get-results pb "stat")))
 774       (setf (mailbox-message-count pb) (car res)))
 775   )
 776
 777
 778 (defmethod unique-id ((pb pop-mailbox) &optional message)
 779   ;; if message is given, return the unique id of that
 780   ;; message,
 781   ;; if message is not given then return a list of lists:
 782   ;;  (message  unique-id)
 783   ;; for all messages not marked as deleted
 784   ;;
 785   (if* message
 786      then (let ((res (send-pop-command-get-results pb
 787                                                    (format nil
 788                                                            "UIDL ~d"
 789                                                            message))))
 790             (cadr res))
 791      else ; get all of them
 792           (let* ((res (send-pop-command-get-results pb "UIDL" t))
 793                  (end (length res))
 794                  kind
 795                  mnum
 796                  mid
 797                  (next 0))
 798
 799
 800             (let ((coll))
 801               (loop
 802                 (multiple-value-setq (kind mnum next)
 803                   (get-next-token res next end))
 804
 805                 (if* (eq :eof kind) then (return))
 806
 807                 (if* (not (eq :number kind))
 808                    then ; hmm. bogus
 809                         (po-error :unexpected
 810                                   :format-control "uidl returned illegal message number in ~s"
 811                                   :format-arguments (list res)))
 812
 813                 ; now get message id
 814
 815                 (multiple-value-setq (kind mid next)
 816                     (get-next-token res next end))
 817
 818                 (if* (eq :number kind)
 819                    then ; looked like a number to the tokenizer,
 820                         ; make it a string to be consistent
 821                         (setq mid (format nil "~d" mid))
 822                  elseif (not (eq :string kind))
 823                    then ; didn't find the uid
 824                         (po-error :unexpected
 825                                   :format-control "uidl returned illegal message id in ~s"
 826                                   :format-arguments (list res)))
 827
 828                 (push (list mnum mid) coll))
 829
 830               (nreverse coll)))))
 831
 832 (defmethod top-lines ((pb pop-mailbox) message lines)
 833   ;; return the header and the given number of top lines of the message
 834
 835   (let ((res (send-pop-command-get-results pb
 836                                            (format nil
 837                                                    "TOP ~d ~d"
 838                                                    message
 839                                                    lines)
 840                                            t ; extra
 841                                            )))
 842     res))
 843
 844
 845
 846
 847
 848
 849 (defun check-for-success (mb command count extra comment command-string )
 850   (declare (ignore mb count extra))
 851   (if* (not (eq command :ok))
 852      then (po-error :error-response
 853                     :format-control "imap ~a failed"
 854                     :format-arguments (list command-string)
 855                     :server-string comment)))
 856
 857
 858
 859
 860
 861 (defmethod mailbox-list ((mb imap-mailbox) &key (reference "") (pattern ""))
 862   ;; return a list of mailbox names with respect to a given
 863   (let (res)
 864     (send-command-get-results mb
 865                               (format nil "list ~s ~s" reference pattern)
 866                               #'(lambda (mb command count extra comment)
 867                                   (if* (eq command :list)
 868                                      then (push extra res)
 869                                      else (handle-untagged-response
 870                                            mb command count extra
 871                                            comment)))
 872                               #'(lambda (mb command count extra comment)
 873                                   (check-for-success
 874                                    mb command count extra
 875                                    comment "list")))
 876
 877     ;; the car of each list is a set of keywords, make that so
 878     (dolist (rr res)
 879       (setf (car rr) (mapcar #'kwd-intern (car rr))))
 880
 881     res
 882
 883
 884     ))
 885
 886
 887 (defmethod create-mailbox ((mb imap-mailbox) mailbox-name)
 888   ;; create a mailbox name of the given name.
 889   ;; use mailbox-separator if you want to create a hierarchy
 890   (send-command-get-results mb
 891                             (format nil "create ~s" mailbox-name)
 892                             #'handle-untagged-response
 893                             #'(lambda (mb command count extra comment)
 894                                   (check-for-success
 895                                    mb command count extra
 896                                    comment "create")))
 897   t)
 898
 899
 900 (defmethod delete-mailbox ((mb imap-mailbox) mailbox-name)
 901   ;; create a mailbox name of the given name.
 902   ;; use mailbox-separator if you want to create a hierarchy
 903   (send-command-get-results mb
 904                             (format nil "delete ~s" mailbox-name)
 905                             #'handle-untagged-response
 906                             #'(lambda (mb command count extra comment)
 907                                   (check-for-success
 908                                    mb command count extra
 909                                    comment "delete"))))
 910
 911 (defmethod rename-mailbox ((mb imap-mailbox) old-mailbox-name new-mailbox-name)
 912   ;; create a mailbox name of the given name.
 913   ;; use mailbox-separator if you want to create a hierarchy
 914   (send-command-get-results mb
 915                             (format nil "rename ~s ~s"
 916                                     old-mailbox-name
 917                                     new-mailbox-name)
 918                             #'handle-untagged-response
 919                             #'(lambda (mb command count extra comment)
 920                                   (check-for-success
 921                                    mb command count extra
 922                                    comment
 923                                    "rename"))))
 924
 925
 926
 927 (defmethod alter-flags ((mb imap-mailbox)
 928                         messages &key (flags nil flags-p)
 929                                       add-flags remove-flags
 930                                       silent uid)
 931   ;;
 932   ;; change the flags using the store command
 933   ;;
 934   (let (cmd val res)
 935     (if* flags-p
 936        then (setq cmd "flags" val flags)
 937      elseif add-flags
 938        then (setq cmd "+flags" val add-flags)
 939      elseif remove-flags
 940        then (setq cmd "-flags" val remove-flags)
 941        else (return-from alter-flags nil))
 942
 943     (if* (atom val) then (setq val (list val)))
 944
 945     (send-command-get-results mb
 946                               (format nil "~astore ~a ~a~a ~a"
 947                                       (if* uid then "uid " else "")
 948                                       (message-set-string messages)
 949                                       cmd
 950                                       (if* silent
 951                                          then ".silent"
 952                                          else "")
 953                                       (if* val
 954                                          thenret
 955                                          else "()"))
 956                               #'(lambda (mb command count extra comment)
 957                                   (if* (eq command :fetch)
 958                                      then (push (list count
 959                                                       (convert-flags-plist
 960                                                        extra))
 961                                                 res)
 962                                      else (handle-untagged-response
 963                                            mb command count extra
 964                                            comment)))
 965
 966                               #'(lambda (mb command count extra comment)
 967                                   (check-for-success
 968                                    mb command count extra
 969                                    comment "store")))
 970     res))
 971
 972
 973 (defun message-set-string (messages)
 974   ;; return a string that describes the messages which may be a
 975   ;; single number or a sequence of numbers
 976
 977   (if* (atom messages)
 978      then (format nil "~a" messages)
 979      else (if* (and (consp messages)
 980                     (eq :seq (car messages)))
 981              then (format nil "~a:~a" (cadr messages) (caddr messages))
 982              else (let ((str (make-string-output-stream))
 983                         (precomma nil))
 984                     (dolist (msg messages)
 985                       (if* precomma then (format str ","))
 986                       (if* (atom msg)
 987                          then (format str "~a" msg)
 988                        elseif (eq :seq (car msg))
 989                          then (format str
 990                                       "~a:~a" (cadr msg) (caddr msg))
 991                          else (po-error :syntax-error
 992                                         :format-control "bad message list ~s"
 993                                         :format-arguments (list msg)))
 994                       (setq precomma t))
 995                     (get-output-stream-string str)))))
 996
 997
 998
 999
1000
1001
1002 (defmethod expunge-mailbox ((mb imap-mailbox))
1003   ;; remove messages marked as deleted
1004   (let (res)
1005     (send-command-get-results mb
1006                               "expunge"
1007                               #'(lambda (mb command count extra
1008                                          comment)
1009                                   (if* (eq command :expunge)
1010                                      then (push count res)
1011                                      else (handle-untagged-response
1012                                            mb command count extra
1013                                            comment)))
1014                               #'(lambda (mb command count extra comment)
1015                                   (check-for-success
1016                                    mb command count extra
1017                                    comment "expunge")))
1018     (nreverse res)))
1019
1020
1021
1022 (defmethod close-mailbox ((mb imap-mailbox))
1023   ;; remove messages marked as deleted
1024   (send-command-get-results mb
1025                             "close"
1026                             #'handle-untagged-response
1027
1028                             #'(lambda (mb command count extra comment)
1029                                 (check-for-success
1030                                  mb command count extra
1031                                  comment "close")))
1032   t)
1033
1034
1035
1036 (defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination
1037                             &key uid)
1038   (send-command-get-results mb
1039                             (format nil "~acopy ~a ~s"
1040                                     (if* uid then "uid " else "")
1041                                     (message-set-string message-list)
1042                                     destination)
1043                             #'handle-untagged-response
1044                             #'(lambda (mb command count extra comment)
1045                                 (check-for-success
1046                                  mb command count extra
1047                                  comment "copy")))
1048   t)
1049
1050
1051 ;; search command
1052
1053 (defmethod search-mailbox ((mb imap-mailbox) search-expression &key uid)
1054   (let (res)
1055     (send-command-get-results mb
1056                               (format nil "~asearch ~a"
1057                                       (if* uid then "uid " else "")
1058                                       (build-search-string search-expression))
1059                               #'(lambda (mb command count extra comment)
1060                                   (if* (eq command :search)
1061                                      then (setq res (append res extra))
1062                                      else (handle-untagged-response
1063                                            mb command count extra
1064                                            comment)))
1065                               #'(lambda (mb command count extra comment)
1066                                   (check-for-success
1067                                    mb command count extra
1068                                    comment "search")))
1069     res))
1070
1071
1072 (defmacro defsearchop (name &rest operands)
1073   (if* (null operands)
1074      then `(setf (get ',name 'imap-search-no-args) t)
1075      else `(setf (get ',name 'imap-search-args) ',operands)))
1076
1077 (defsearchop :all)
1078 (defsearchop :answered)
1079 (defsearchop :bcc :str)
1080 (defsearchop :before :date)
1081 (defsearchop :body :str)
1082 (defsearchop :cc :str)
1083 (defsearchop :deleted)
1084 (defsearchop :draft)
1085 (defsearchop :flagged)
1086 (defsearchop :from :str)
1087 (defsearchop :header :str :str)
1088 (defsearchop :keyword :flag)
1089 (defsearchop :larger :number)
1090 (defsearchop :new)
1091 (defsearchop :old)
1092 (defsearchop :on :date)
1093 (defsearchop :recent)
1094 (defsearchop :seen)
1095 (defsearchop :sentbefore :date)
1096 (defsearchop :senton :date)
1097 (defsearchop :sentsince :date)
1098 (defsearchop :since :date)
1099 (defsearchop :smaller :number)
1100 (defsearchop :subject :str)
1101 (defsearchop :text :str)
1102 (defsearchop :to :str)
1103 (defsearchop :uid :messageset)
1104 (defsearchop :unanswered)
1105 (defsearchop :undeleted)
1106 (defsearchop :undraft)
1107 (defsearchop :unflagged)
1108 (defsearchop :unkeyword :flag)
1109 (defsearchop :unseen)
1110
1111
1112
1113 (defun build-search-string (search)
1114   ;; take the lisp search form and turn it into a string that can be
1115   ;; passed to imap
1116
1117   (if* (null search)
1118      then ""
1119      else (let ((str (make-string-output-stream)))
1120             (bss-int search str)
1121             (get-output-stream-string str))))
1122
1123 (defun bss-int (search str)
1124   ;;* it turns out that imap (on linux) is very picky about spaces....
1125   ;; any extra whitespace will result in failed searches
1126   ;;
1127   (labels ((and-ify (srch str)
1128              (let ((spaceout nil))
1129                (dolist (xx srch)
1130                  (if* spaceout then (format str " "))
1131                  (bss-int xx str)
1132                  (setq spaceout t))))
1133            (or-ify (srch str)
1134              ; only binary or allowed in imap but we support n-ary
1135              ; or in this interface
1136              (if* (null (cdr srch))
1137                 then (bss-int (car srch) str)
1138               elseif (cddr srch)
1139                 then ; over two clauses
1140                      (format str "or (")
1141                      (bss-int (car srch) str)
1142                      (format str  ") (")
1143                      (or-ify (cdr srch) str)
1144                      (format str ")")
1145                 else ; 2 args
1146                      (format str "or (" )
1147                      (bss-int (car srch) str)
1148                      (format str ") (")
1149                      (bss-int (cadr srch) str)
1150                      (format str ")")))
1151            (set-ify (srch str)
1152              ;; a sequence of messages
1153              (do* ((xsrch srch (cdr xsrch))
1154                    (val (car xsrch) (car xsrch)))
1155                  ((null xsrch))
1156                (if* (integerp val)
1157                   then (format str "~s" val)
1158                 elseif (and (consp val)
1159                             (eq :seq (car val))
1160                             (eq 3 (length val)))
1161                   then (format str "~s:~s" (cadr val) (caddr val))
1162                   else (po-error :syntax-error
1163                                  :format-control "illegal set format ~s"
1164                                  :format-arguments (list val)))
1165                (if* (cdr xsrch) then (format str ","))))
1166            (arg-process (str args arginfo)
1167              ;; process and print each arg to str
1168              ;; assert (length of args and arginfo are the same)
1169              (do* ((x-args args (cdr x-args))
1170                    (val (car x-args) (car x-args))
1171                    (x-arginfo arginfo (cdr x-arginfo)))
1172                  ((null x-args))
1173                (ecase (car x-arginfo)
1174                  (:str
1175                   ; print it as a string
1176                   (format str " \"~a\"" (car x-args)))
1177                  (:date
1178
1179                   (if* (integerp val)
1180                      then (setq val (universal-time-to-rfc822-date
1181                                      val))
1182                    elseif (not (stringp val))
1183                      then (po-error :syntax-error
1184                                     :format-control "illegal value for date search ~s"
1185                                     :format-arguments (list val)))
1186                   ;; val is now a string
1187                   (format str " ~s" val))
1188                  (:number
1189
1190                   (if* (not (integerp val))
1191                      then (po-error :syntax-error
1192                                     :format-control "illegal value for number in search ~s"
1193                                     :format-arguments (list val)))
1194                   (format str " ~s" val))
1195                  (:flag
1196
1197                   ;; should be a symbol in the kwd package
1198                   (setq val (string val))
1199                   (format str " ~s" val))
1200                  (:messageset
1201                   (if* (numberp val)
1202                      then (format str " ~s" val)
1203                    elseif (consp val)
1204                      then (set-ify val str)
1205                      else (po-error :syntax-error
1206                                     :format-control "illegal message set ~s"
1207                                     :format-arguments (list val))))
1208
1209                  ))))
1210
1211     (if* (symbolp search)
1212        then (if* (get search 'imap-search-no-args)
1213                then (format str "~a"  (string-upcase
1214                                        (string search)))
1215                else (po-error :syntax-error
1216                               :format-control "illegal search word: ~s"
1217                               :format-arguments (list search)))
1218      elseif (consp search)
1219        then (case (car search)
1220               (and (if* (null (cdr search))
1221                       then (bss-int :all str)
1222                     elseif (null (cddr search))
1223                       then (bss-int (cadr search) str)
1224                       else (and-ify (cdr search)  str)))
1225               (or  (if* (null (cdr search))
1226                       then (bss-int :all str)
1227                     elseif (null (cddr search))
1228                       then (bss-int (cadr search) str)
1229                       else (or-ify (cdr search)  str)))
1230               (not (if* (not (eql (length search) 2))
1231                       then (po-error :syntax-error
1232                                      :format-control "not takes one argument: ~s"
1233                                      :format-arguments (list search)))
1234                    (format str "not (" )
1235                    (bss-int (cadr search) str)
1236                    (format str ")"))
1237               (:seq
1238                (set-ify (list search) str))
1239               (t (let (arginfo)
1240                    (if* (and (symbolp (car search))
1241                              (setq arginfo (get (car search)
1242                                                 'imap-search-args)))
1243                       then
1244                            (format str "~a" (string-upcase
1245                                              (string (car search))))
1246                            (if* (not (equal (length (cdr search))
1247                                             (length arginfo)))
1248                               then (po-error :syntax-error
1249                                              :format-control "wrong number of arguments to ~s"
1250                                              :format-arguments search))
1251
1252                            (arg-process str (cdr search) arginfo)
1253
1254                     elseif (integerp (car search))
1255                       then (set-ify search str)
1256                       else (po-error :syntax-error
1257                                      :format-control "Illegal form ~s in search string"
1258                                      :format-arguments (list search))))))
1259      elseif (integerp search)
1260        then ;  a message number
1261             (format str "~s" search)
1262        else (po-error :syntax-error
1263                       :format-control "Illegal form ~s in search string"
1264                       :format-arguments (list search)))))
1265
1266
1267
1268
1269
1270 (defun parse-mail-header (text)
1271   ;; given the partial text of a mail message that includes
1272   ;; at least the header part, return an assoc list of
1273   ;; (header . content)  items
1274   ;; Note that the header is string with most likely mixed case names
1275   ;; as it's conventional to capitalize header names.
1276   (let ((next 0)
1277         (end (length text))
1278         header
1279         value
1280         kind
1281         headers)
1282     (labels ((next-header-line ()
1283                ;; find the next header line return
1284                ;; :eof - no more
1285                ;; :start - beginning of header value, header and
1286                ;;                value set
1287                ;; :continue - continuation of previous header line
1288
1289
1290                (let ((state 1)
1291                      beginv  ; charpos beginning value
1292                      beginh  ; charpos beginning header
1293                      ch
1294                      )
1295                  (tagbody again
1296
1297                    (return-from next-header-line
1298
1299                      (loop  ; for each character
1300
1301                        (if* (>= next end)
1302                           then (return :eof))
1303
1304                        (setq ch (char text next))
1305                        (if* (eq ch #\return)
1306                           thenret  ; ignore return, (handle following linefeed)
1307                           else (case state
1308                                  (1 ; no characters seen
1309                                   (if* (eq ch #\linefeed)
1310                                      then (incf next)
1311                                           (return :eof)
1312                                    elseif (member ch
1313                                                   '(#\space
1314                                                     #\tab))
1315                                      then ; continuation
1316                                           (setq state 2)
1317                                      else (setq beginh next)
1318                                           (setq state 3)
1319                                           ))
1320                                  (2 ; looking for first non blank in value
1321                                   (if* (eq ch #\linefeed)
1322                                      then ; empty continuation line, ignore
1323                                           (incf next)
1324                                           (go again)
1325                                    elseif (not (member ch
1326                                                        (member ch
1327                                                                '(#\space
1328                                                                  #\tab))))
1329                                      then ; begin value part
1330                                           (setq beginv next)
1331                                           (setq state 4)))
1332                                  (3 ; reading the header
1333                                   (if* (eq ch #\linefeed)
1334                                      then ; bogus header line, ignore
1335                                           (go again)
1336                                    elseif (eq ch #\:)
1337                                      then (setq header
1338                                             (subseq text beginh next))
1339                                           (setq state 2)))
1340                                  (4 ; looking for the end of the value
1341                                   (if* (eq ch #\linefeed)
1342                                      then (setq value
1343                                             (subseq text beginv
1344                                                     (if* (eq #\return
1345                                                              (char text
1346                                                                    (1- next)))
1347                                                        then (1- next)
1348                                                        else next)))
1349                                           (incf next)
1350                                           (return (if* header
1351                                                      then :start
1352                                                      else :continue))))))
1353                        (incf next)))))))
1354
1355
1356
1357       (loop ; for each header line
1358         (setq header nil)
1359         (if* (eq :eof (setq kind (next-header-line)))
1360            then (return))
1361         (case kind
1362           (:start (push (cons header value) headers))
1363           (:continue
1364            (if* headers
1365               then ; append to previous one
1366                    (setf (cdr (car headers))
1367                      (concatenate 'string (cdr (car headers))
1368                                   " "
1369                                   value)))))))
1370     (values headers
1371             (subseq text next end))))
1372
1373
1374 (defun make-envelope-from-text (text)
1375   ;; given at least the headers part of a message return
1376   ;; an envelope structure containing the contents
1377   ;; This is useful for parsing the headers of things returned by
1378   ;; a pop server
1379   ;;
1380   (let ((headers (parse-mail-header text)))
1381
1382     (make-envelope
1383      :date     (cdr (assoc "date" headers :test #'equalp))
1384      :subject  (cdr (assoc "subject" headers :test #'equalp))
1385      :from     (cdr (assoc "from" headers :test #'equalp))
1386      :sender   (cdr (assoc "sender" headers :test #'equalp))
1387      :reply-to (cdr (assoc "reply-to" headers :test #'equalp))
1388      :to       (cdr (assoc "to" headers :test #'equalp))
1389      :cc       (cdr (assoc "cc" headers :test #'equalp))
1390      :bcc      (cdr (assoc "bcc" headers :test #'equalp))
1391      :in-reply-to (cdr (assoc "in-reply-to" headers :test #'equalp))
1392      :message-id (cdr (assoc "message-id" headers :test #'equalp))
1393      )))
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404 (defmethod get-and-parse-from-imap-server ((mb imap-mailbox))
1405   ;; read the next line and parse it
1406   ;;
1407   ;;
1408   (multiple-value-bind (line count)
1409       (get-line-from-server mb)
1410     (if* *debug-imap*
1411        then (format t "from server: ")
1412             (dotimes (i count)(write-char (schar line i)))
1413             (terpri)
1414             (force-output))
1415
1416     (parse-imap-response line count)
1417     ))
1418
1419
1420
1421 (defmethod get-and-parse-from-pop-server ((mb pop-mailbox))
1422   ;; read the next line from the pop server
1423   ;;
1424   ;; return 3 values:
1425   ;;   :ok or :error
1426   ;;   a list of rest of the tokens on the line
1427   ;;   the whole line after the +ok or -err
1428
1429   (multiple-value-bind (line count)
1430       (get-line-from-server mb)
1431
1432     (if* *debug-imap*
1433        then (format t "from server: " count)
1434             (dotimes (i count)(write-char (schar line i)))
1435             (terpri))
1436
1437     (parse-pop-response line count)))
1438
1439
1440
1441 ;; Parse and return the data from each line
1442 ;; values returned
1443 ;;  tag -- either a string or the symbol :untagged
1444 ;;  command -- a keyword symbol naming the command, like :ok
1445 ;;  count -- a number which preceeded the command, or nil if
1446 ;;           there wasn't a command
1447 ;;  bracketted - a list of objects found in []'s after the command
1448 ;;            or in ()'s after the command  or sometimes just
1449 ;;            out in the open after the command (like the search)
1450 ;;  comment  -- the whole of the part after the command
1451 ;;
1452 (defun parse-imap-response (line end)
1453   (let (kind value next
1454         tag count command extra-data
1455         comment)
1456
1457     ;; get tag
1458     (multiple-value-setq (kind value next)
1459       (get-next-token line 0 end))
1460
1461     (case kind
1462       (:string (setq tag (if* (equal value "*")
1463                             then :untagged
1464                             else value)))
1465       (t (po-error :unexpected
1466                    :format-control "Illegal tag on response: ~s"
1467                    :format-arguments (list (subseq line 0 count))
1468                    :server-string (subseq line 0 end)
1469                    )))
1470
1471     ;; get command
1472     (multiple-value-setq (kind value next)
1473       (get-next-token line next end))
1474
1475     (tagbody again
1476       (case kind
1477         (:number (setq count value)
1478                  (multiple-value-setq (kind value next)
1479                    (get-next-token line next end))
1480                  (go again))
1481         (:string (setq command (kwd-intern value)))
1482         (t (po-error :unexpected
1483                      :format-control "Illegal command on response: ~s"
1484                      :format-arguments (list (subseq line 0 count))
1485                      :server-string (subseq line 0 end)))))
1486
1487     (setq comment (subseq line next end))
1488
1489     ;; now the part after the command... this gets tricky
1490     (loop
1491       (multiple-value-setq (kind value next)
1492         (get-next-token line next end))
1493
1494       (case kind
1495         ((:lbracket :lparen)
1496          (multiple-value-setq (kind value next)
1497            (get-next-sexpr line (1- next) end))
1498          (case kind
1499            (:sexpr (push value extra-data))
1500            (t (po-error :syntax-error :format-control "bad sexpr form"))))
1501         (:eof (return nil))
1502         ((:number :string :nil) (push value extra-data))
1503         (t  ; should never happen
1504          (return)))
1505
1506       (if* (not (member command '(:list :search) :test #'eq))
1507          then ; only one item returned
1508               (setq extra-data (car extra-data))
1509               (return)))
1510
1511     (if* (member command '(:list :search) :test #'eq)
1512        then (setq extra-data (nreverse extra-data)))
1513
1514
1515     (values tag command count extra-data comment)))
1516
1517
1518
1519 (defun get-next-sexpr (line start end)
1520   ;; read a whole s-expression
1521   ;; return 3 values
1522   ;;   kind -- :sexpr  or :rparen or :rbracket
1523   ;;   value - the sexpr value
1524   ;;   next  - next charpos to scan
1525   ;;
1526   (let ( kind value next)
1527     (multiple-value-setq (kind value next) (get-next-token line start end))
1528
1529     (case kind
1530       ((:string :number :nil)
1531        (values :sexpr value next))
1532       (:eof (po-error :syntax-error
1533                       :format-control "eof inside sexpr"))
1534       ((:lbracket :lparen)
1535        (let (res)
1536          (loop
1537            (multiple-value-setq (kind value next)
1538              (get-next-sexpr line next end))
1539            (case kind
1540              (:sexpr (push value res))
1541              ((:rparen :rbracket)
1542               (return (values :sexpr (nreverse res) next)))
1543              (t (po-error :syntax-error
1544                           :format-control "bad sexpression"))))))
1545       ((:rbracket :rparen)
1546        (values kind nil next))
1547       (t (po-error :syntax-error
1548                    :format-control "bad sexpression")))))
1549
1550
1551 (defun parse-pop-response (line end)
1552   ;; return 3 values:
1553   ;;   :ok or :error
1554   ;;   a list of rest of the tokens on the line, the tokens
1555   ;;     being either strings or integers
1556   ;;   the whole line after the +ok or -err
1557   ;;
1558   (let (res lineres result)
1559     (multiple-value-bind (kind value next)
1560         (get-next-token line 0 end)
1561
1562       (case kind
1563         (:string (setq result (if* (equal "+OK" value)
1564                                  then :ok
1565                                  else :error)))
1566         (t (po-error :unexpected
1567                      :format-control "bad response from server"
1568                      :server-string (subseq line 0 end))))
1569
1570       (setq lineres (subseq line next end))
1571
1572       (loop
1573         (multiple-value-setq (kind value next)
1574           (get-next-token line next end))
1575
1576         (case kind
1577           (:eof (return))
1578           ((:string :number) (push value res))))
1579
1580       (values result (nreverse res) lineres))))
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591 (defparameter *char-to-kind*
1592     (let ((arr (make-array 256 :initial-element nil)))
1593
1594       (do ((i #.(char-code #\0) (1+ i)))
1595           ((> i #.(char-code #\9)))
1596         (setf (aref arr i) :number))
1597
1598       (setf (aref arr #.(char-code #\space)) :space)
1599       (setf (aref arr #.(char-code #\tab)) :space)
1600       (setf (aref arr #.(char-code #\return)) :space)
1601       (setf (aref arr #.(char-code #\linefeed)) :space)
1602
1603       (setf (aref arr #.(char-code #\[)) :lbracket)
1604       (setf (aref arr #.(char-code #\])) :rbracket)
1605       (setf (aref arr #.(char-code #\()) :lparen)
1606       (setf (aref arr #.(char-code #\))) :rparen)
1607       (setf (aref arr #.(char-code #\")) :dquote)
1608
1609       (setf (aref arr #.(char-code #\^b)) :big-string) ; our own invention
1610
1611       arr))
1612
1613
1614 (defun get-next-token (line start end)
1615   ;; scan past whitespace for the next token
1616   ;; return three values:
1617   ;;  kind:  :string , :number, :eof, :lbracket, :rbracket,
1618   ;;            :lparen, :rparen
1619   ;;  value:  the value, either a string or number or nil
1620   ;;  next:   the character pos to start scanning for the next token
1621   ;;
1622   (let (ch chkind colstart (count 0) (state :looking)
1623         collector right-bracket-is-normal)
1624     (loop
1625       ; pick up the next character
1626       (if* (>= start end)
1627          then (if* (eq state :looking)
1628                  then (return (values :eof nil start))
1629                  else (setq ch #\space))
1630          else (setq ch (schar line start)))
1631
1632       (setq chkind (aref *char-to-kind* (char-code ch)))
1633
1634       (case state
1635         (:looking
1636          (case chkind
1637            (:space nil)
1638            (:number (setq state :number)
1639                     (setq colstart start)
1640                     (setq count (- (char-code ch) #.(char-code #\0))))
1641            ((:lbracket :lparen :rbracket :rparen)
1642             (return (values chkind nil (1+ start))))
1643            (:dquote
1644             (setq collector (make-array 10
1645                                         :element-type 'character
1646                                         :adjustable t
1647                                         :fill-pointer 0))
1648             (setq state :qstring))
1649            (:big-string
1650             (setq colstart (1+ start))
1651             (setq state :big-string))
1652            (t (setq colstart start)
1653               (setq state :literal))))
1654         (:number
1655          (case chkind
1656            ((:space :lbracket :lparen :rbracket :rparen
1657              :dquote) ; end of number
1658             (return (values :number count  start)))
1659            (:number ; more number
1660             (setq count (+ (* count 10)
1661                            (- (char-code ch) #.(char-code #\0)))))
1662            (t ; turn into an literal
1663             (setq state :literal))))
1664         (:literal
1665          (case chkind
1666            ((:space :rbracket :lparen :rparen :dquote) ; end of literal
1667             (if* (and (eq chkind :rbracket)
1668                       right-bracket-is-normal)
1669                then nil ; don't stop now
1670                else (let ((seq (subseq line colstart start)))
1671                       (if* (equal "NIL" seq)
1672                          then (return (values :nil
1673                                               nil
1674                                               start))
1675                          else (return (values :string
1676                                               seq
1677                                               start))))))
1678            (t (if* (eq chkind :lbracket)
1679                  then ; imbedded left bracket so right bracket isn't
1680                       ; a break char
1681                       (setq right-bracket-is-normal t))
1682               nil)))
1683         (:qstring
1684          ;; quoted string
1685          ; (format t "start is ~s  kind is ~s~%" start chkind)
1686          (case chkind
1687            (:dquote
1688             ;; end of string
1689             (return (values :string collector (1+ start))))
1690            (t (if* (eq ch #\\)
1691                  then ; escaping the next character
1692                       (incf start)
1693                       (if* (>= start end)
1694                          then (po-error :unexpected
1695                                         :format-control "eof in string returned"))
1696                       (setq ch (schar line start)))
1697               (vector-push-extend ch collector)
1698
1699               (if* (>= start end)
1700                  then ; we overran the end of the input
1701                       (po-error :unexpected
1702                                 :format-control "eof in string returned")))))
1703         (:big-string
1704          ;; super string... just a block of data
1705          ; (format t "start is ~s  kind is ~s~%" start chkind)
1706          (case chkind
1707            (:big-string
1708             ;; end of string
1709             (return (values :string
1710                             (subseq line colstart start)
1711                             (1+ start))))
1712            (t nil)))
1713
1714
1715         )
1716
1717       (incf start))))
1718
1719
1720
1721 ;  this used to be exported from the excl package
1722 #+(version>= 6 0)
1723 (defvar *keyword-package* (find-package :keyword))
1724
1725
1726 (defun kwd-intern (string)
1727   ;; convert the string to the current preferred case
1728   ;; and then intern
1729   (intern (case excl::*current-case-mode*
1730             ((:case-sensitive-lower
1731               :case-insensitive-lower) (string-downcase string))
1732             (t (string-upcase string)))
1733           *keyword-package*))
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748 ;; low level i/o to server
1749
1750 (defun get-line-from-server (mailbox)
1751   ;; Return two values:  a buffer and a character count.
1752   ;; The character count includes up to but excluding the cr lf that
1753   ;;  was read from the socket.
1754   ;;
1755   (let* ((buff (get-line-buffer 0))
1756          (len  (length buff))
1757          (i 0)
1758          (p (post-office-socket mailbox))
1759          (ch nil)
1760          (whole-count)
1761          )
1762
1763     (handler-case
1764         (flet ((grow-buffer (size)
1765                  (let ((newbuff (get-line-buffer size)))
1766                    (dotimes (j i)
1767                      (setf (schar newbuff j) (schar buff j)))
1768                    (free-line-buffer buff)
1769                    (setq buff newbuff)
1770                    (setq len (length buff)))))
1771
1772           ;; increase the buffer to at least size
1773           ;; this is somewhat complex to ensure that we aren't doing
1774           ;; buffer allocation within the with-timeout form, since
1775           ;; that could trigger a gc which could then cause the
1776           ;; with-timeout form to expire.
1777           (loop
1778
1779             (if* whole-count
1780                then ; we should now read in this may bytes and
1781                     ; append it to this buffer
1782                     (multiple-value-bind (ans this-count)
1783                         (get-block-of-data-from-server mailbox whole-count)
1784                       ; now put this data in the current buffer
1785                       (if* (> (+ i whole-count 5) len)
1786                          then  ; grow the initial buffer
1787                               (grow-buffer (+ i whole-count 100)))
1788
1789                       (dotimes (ind this-count)
1790                         (setf (schar buff i) (schar ans ind))
1791                         (incf i))
1792                       (setf (schar buff i) #\^b) ; end of inset string
1793                       (incf i)
1794                       (free-line-buffer ans)
1795                       (setq whole-count nil)
1796                       )
1797              elseif ch
1798                then ; we're growing the buffer holding the line data
1799                     (grow-buffer (+ len 200))
1800                     (setf (schar buff i) ch)
1801                     (incf i))
1802
1803
1804             (block timeout
1805               (mp:with-timeout ((timeout mailbox)
1806                                 (po-error :timeout
1807                                           :format-control "imap server failed to respond"))
1808                 ;; read up to lf  (lf most likely preceeded by cr)
1809                 (loop
1810                   (setq ch (read-char p))
1811                   (if* (eq #\linefeed ch)
1812                      then ; end of line. Don't save the return
1813                           (if* (and (> i 0)
1814                                     (eq (schar buff (1- i)) #\return))
1815                              then ; remove #\return, replace with newline
1816                                   (decf i)
1817                                   (setf (schar buff i) #\newline)
1818                                   )
1819                           ;; must check for an extended return value which
1820                           ;; is indicated by a {nnn} at the end of the line
1821                           (block count-check
1822                             (let ((ind (1- i)))
1823                               (if* (and (>= i 0) (eq (schar buff ind) #\}))
1824                                  then (let ((count 0)
1825                                             (mult 1))
1826                                         (loop
1827                                           (decf ind)
1828                                           (if* (< ind 0)
1829                                              then ; no of the form {nnn}
1830                                                   (return-from count-check))
1831                                           (setf ch (schar buff ind))
1832                                           (if* (eq ch #\{)
1833                                              then ; must now read that many bytes
1834                                                   (setf (schar buff ind) #\^b)
1835                                                   (setq whole-count count)
1836                                                   (setq i (1+ ind))
1837                                                   (return-from timeout)
1838                                            elseif (<= #.(char-code #\0)
1839                                                       (char-code ch)
1840                                                       #.(char-code #\9))
1841                                              then ; is a digit
1842                                                   (setq count
1843                                                     (+ count
1844                                                        (* mult
1845                                                           (- (char-code ch)
1846                                                              #.(char-code #\0)))))
1847                                                   (setq mult (* 10 mult))
1848                                              else ; invalid form, get out
1849                                                   (return-from count-check)))))))
1850
1851
1852                           (return-from get-line-from-server
1853                             (values buff i))
1854                      else ; save character
1855                           (if* (>= i len)
1856                              then ; need bigger buffer
1857                                   (return))
1858                           (setf (schar buff i) ch)
1859                           (incf i)))))))
1860       (error (con)
1861         ;; most likely error is that the server went away
1862         (ignore-errors (close p))
1863         (po-error :server-shutdown-connection
1864                   :format-control "condition  signalled: ~a~%most likely server shut down the connection."
1865                   :format-arguments (list con)))
1866       )))
1867
1868
1869 (defun get-block-of-data-from-server  (mb count &key save-returns)
1870   ;; read count bytes from the server returning it in a line buffer object
1871   ;; return as a second value the number of characters saved
1872   ;; (we drop #\return's so that lines are sepisarated by a #\newline
1873   ;; like lisp likes).
1874   ;;
1875   (let ((buff (get-line-buffer count))
1876         (p (post-office-socket mb))
1877         (ind 0))
1878     (mp:with-timeout ((timeout mb)
1879                       (po-error :timeout
1880                                 :format-control "imap server timed out"))
1881
1882       (dotimes (i count)
1883         (if* (eq #\return (setf (schar buff ind) (read-char p)))
1884            then (if* save-returns then (incf ind)) ; drop #\returns
1885            else (incf ind)))
1886
1887
1888       (values buff ind))))
1889
1890
1891 ;;-- reusable line buffers
1892
1893 (defvar *line-buffers* nil)
1894
1895 (defun get-line-buffer (size)
1896   ;; get a buffer of at least size bytes
1897   (setq size (min size (1- array-total-size-limit)))
1898   (mp::without-scheduling
1899     (dolist (buff *line-buffers* (make-string size))
1900         (if* (>= (length buff) size)
1901            then ; use this one
1902                 (setq *line-buffers* (delete buff *line-buffers*))
1903                 (return buff)))))
1904
1905
1906 (defun free-line-buffer (buff)
1907   (mp:without-scheduling
1908     (push buff *line-buffers*)))
1909
1910 (defun init-line-buffer (new old)
1911   ;; copy old into new
1912   (declare (optimize (speed 3)))
1913   (dotimes (i (length old))
1914     (declare (fixnum i))
1915     (setf (schar new i) (schar old i))))
1916
1917
1918
1919
1920   ;;;;;;;
1921
1922 ; date functions
1923
1924 (defun universal-time-to-rfc822-date (ut)
1925   ;; convert a lisp universal time to rfc 822 date
1926   ;;
1927   (multiple-value-bind
1928       (sec min hour date month year day-of-week dsp time-zone)
1929       (decode-universal-time ut 0)
1930     (declare (ignore time-zone sec min hour day-of-week dsp time-zone))
1931     (format nil "~d-~a-~d"
1932             date
1933             (svref
1934              '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
1935                 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
1936              month
1937              )
1938             year)))
1939
1940
1941
1942