imap.lisp

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