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