cgit.sxemacs.org Git - gnus/blob - lisp/nnimap.el

   1 ;;; nnimap.el --- IMAP interface for Gnus
   2
   3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;         Simon Josefsson <simon@josefsson.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; nnimap interfaces Gnus with IMAP servers.
  26
  27 ;;; Code:
  28
  29 (eval-and-compile
  30   (require 'nnheader))
  31
  32 (nnoo-declare nnimap)
  33
  34 (defvoo nnimap-address nil
  35   "The address of the IMAP server.")
  36
  37 (defvoo nnimap-server-port nil
  38   "The IMAP port used.
  39 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
  40 it will default to `imap'.")
  41
  42 (defvoo nnimap-stream 'ssl
  43   "How nnimap will talk to the IMAP server.
  44 Values are `ssl' and `network'.")
  45
  46 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
  47                                  (if (listp imap-shell-program)
  48                                      (car imap-shell-program)
  49                                    imap-shell-program)
  50                                "ssh %s imapd"))
  51
  52 (defvoo nnimap-inbox nil
  53   "The mail box where incoming mail arrives and should be split out of.")
  54
  55 (defvoo nnimap-expunge-inbox nil
  56   "If non-nil, expunge the inbox after fetching mail.
  57 This is always done if the server supports UID EXPUNGE, but it's
  58 not done by default on servers that doesn't support that command.")
  59
  60 (defvoo nnimap-connection-alist nil)
  61 (defvar nnimap-process nil)
  62
  63 (defvar nnimap-status-string "")
  64
  65 (defvar nnimap-split-download-body-default nil
  66   "Internal variable with default value for `nnimap-split-download-body'.")
  67
  68 (defstruct nnimap
  69   group process commands capabilities)
  70
  71 (defvar nnimap-object nil)
  72
  73 (defvar nnimap-mark-alist
  74   '((read "\\Seen")
  75     (tick "\\Flagged")
  76     (reply "\\Answered")
  77     (expire "gnus-expire")
  78     (dormant "gnus-dormant")
  79     (score "gnus-score")
  80     (save "gnus-save")
  81     (download "gnus-download")
  82     (forward "gnus-forward")))
  83
  84 (defvar nnimap-split-methods nil)
  85
  86 (defun nnimap-buffer ()
  87   (nnimap-find-process-buffer nntp-server-buffer))
  88
  89 (defmacro nnimap-with-process-buffer (&rest body)
  90   `(with-current-buffer (nnimap-find-process-buffer (current-buffer))
  91      ,@body))
  92
  93 (defun nnimap-retrieve-headers (articles &optional group server fetch-old)
  94   (with-current-buffer nntp-server-buffer
  95     (erase-buffer)
  96     (when (nnimap-possibly-change-group group server)
  97       (with-current-buffer (nnimap-buffer)
  98         (nnimap-send-command "SELECT %S" (utf7-encode group t))
  99         (erase-buffer)
 100         (nnimap-wait-for-response
 101          (nnimap-send-command
 102           "UID FETCH %s %s"
 103           (nnimap-article-ranges (gnus-compress-sequence articles))
 104           (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
 105                   (format
 106                    (if (member "IMAP4REV1"
 107                                (nnimap-capabilities nnimap-object))
 108                        "BODY.PEEK[HEADER.FIELDS %s]"
 109                      "RFC822.HEADER.LINES %s")
 110                    (append '(Subject From Date Message-Id
 111                                      References In-Reply-To Xref)
 112                            nnmail-extra-headers))))
 113          t)
 114         (nnimap-transform-headers))
 115       (insert-buffer-substring
 116        (nnimap-find-process-buffer (current-buffer))))
 117     t))
 118
 119 (defun nnimap-transform-headers ()
 120   (goto-char (point-min))
 121   (let (article bytes lines)
 122     (block nil
 123       (while (not (eobp))
 124         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 125           (delete-region (point) (progn (forward-line 1) (point)))
 126           (when (eobp)
 127             (return)))
 128         (setq article (match-string 1)
 129               bytes (nnimap-get-length)
 130               lines nil)
 131         (beginning-of-line)
 132         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
 133           (let ((structure (ignore-errors (read (current-buffer)))))
 134             (while (and (consp structure)
 135                         (not (stringp (car structure))))
 136               (setq structure (car structure)))
 137             (setq lines (nth 7 structure))))
 138         (delete-region (line-beginning-position) (line-end-position))
 139         (insert (format "211 %s Article retrieved." article))
 140         (forward-line 1)
 141         (insert (format "Bytes: %d\n" bytes))
 142         (when lines
 143           (insert (format "Lines: %s\n" lines)))
 144         (re-search-forward "^\r$")
 145         (delete-region (line-beginning-position) (line-end-position))
 146         (insert ".")
 147         (forward-line 1)))))
 148
 149 (defun nnimap-get-length ()
 150   (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
 151        (string-to-number (match-string 1))))
 152
 153 (defun nnimap-article-ranges (ranges)
 154   (let (result)
 155     (cond
 156      ((numberp ranges)
 157       (number-to-string ranges))
 158      ((numberp (cdr ranges))
 159       (format "%d:%d" (car ranges) (cdr ranges)))
 160      (t
 161       (dolist (elem ranges)
 162         (push
 163          (if (consp elem)
 164              (format "%d:%d" (car elem) (cdr elem))
 165            (number-to-string elem))
 166          result))
 167       (mapconcat #'identity (nreverse result) ",")))))
 168
 169 (defun nnimap-open-server (server &optional defs)
 170   (if (nnimap-server-opened server)
 171       t
 172     (unless (assq 'nnimap-address defs)
 173       (setq defs (append defs (list (list 'nnimap-address server)))))
 174     (nnoo-change-server 'nnimap server defs)
 175     (or (nnimap-find-connection nntp-server-buffer)
 176         (nnimap-open-connection nntp-server-buffer))))
 177
 178 (defun nnimap-make-process-buffer (buffer)
 179   (with-current-buffer
 180       (generate-new-buffer (format "*nnimap %s %s %s*"
 181                                    nnimap-address nnimap-server-port
 182                                    (gnus-buffer-exists-p buffer)))
 183     (mm-disable-multibyte)
 184     (buffer-disable-undo)
 185     (gnus-add-buffer)
 186     (set (make-local-variable 'after-change-functions) nil)
 187     (set (make-local-variable 'nnimap-object) (make-nnimap))
 188     (push (list buffer (current-buffer)) nnimap-connection-alist)
 189     (current-buffer)))
 190
 191 (defun nnimap-open-shell-stream (name buffer host port)
 192   (let ((process (start-process name buffer shell-file-name
 193                                 shell-command-switch
 194                                 (format-spec
 195                                  nnimap-shell-program
 196                                  (format-spec-make
 197                                   ?s host
 198                                   ?p port)))))
 199     process))
 200
 201 (defun nnimap-open-connection (buffer)
 202   (with-current-buffer (nnimap-make-process-buffer buffer)
 203     (let* ((coding-system-for-read 'binary)
 204            (coding-system-for-write 'binary)
 205            (credentials
 206             (cond
 207              ((eq nnimap-stream 'network)
 208               (open-network-stream "*nnimap*" (current-buffer) nnimap-address
 209                                    (or nnimap-server-port "imap"))
 210               (netrc-credentials nnimap-address "imap"))
 211              ((eq nnimap-stream 'stream)
 212               (nnimap-open-shell-stream
 213                "*nnimap*" (current-buffer) nnimap-address
 214                (or nnimap-server-port "imap"))
 215               (netrc-credentials nnimap-address "imap"))
 216              ((eq nnimap-stream 'ssl)
 217               (open-tls-stream "*nnimap*" (current-buffer) nnimap-address
 218                                (or nnimap-server-port "imaps"))
 219               (netrc-credentials nnimap-address "imaps" "imap")))))
 220       (setf (nnimap-process nnimap-object)
 221             (get-buffer-process (current-buffer)))
 222       (unless credentials
 223         (delete-process (nnimap-process nnimap-object))
 224         (error "Can't find user name/password for %s" nnimap-address))
 225       (when (and (nnimap-process nnimap-object)
 226                  (memq (process-status (nnimap-process nnimap-object))
 227                        '(open run)))
 228         (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
 229         (let ((result (nnimap-command "LOGIN %S %S"
 230                                       (car credentials) (cadr credentials))))
 231           (unless (car result)
 232             (delete-process (nnimap-process nnimap-object))
 233             (error "Unable to login to the server: %s"
 234                    (mapconcat #'identity (cadr result) " ")))
 235           (setf (nnimap-capabilities nnimap-object)
 236                 (mapcar
 237                  #'upcase
 238                  (or (nnimap-find-parameter "CAPABILITY" (cdr result))
 239                      (nnimap-find-parameter
 240                       "CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))))
 241           (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
 242             (nnimap-command "ENABLE QRESYNC"))
 243           t)))))
 244
 245 (defun nnimap-find-parameter (parameter elems)
 246   (let (result)
 247     (dolist (elem elems)
 248       (cond
 249        ((equal (car elem) parameter)
 250         (setq result (cdr elem)))
 251        ((and (equal (car elem) "OK")
 252              (consp (cadr elem))
 253              (equal (caadr elem) parameter))
 254         (setq result (cdr (cadr elem))))))
 255     result))
 256
 257 (defun nnimap-close-server (&optional server)
 258   t)
 259
 260 (defun nnimap-request-close ()
 261   t)
 262
 263 (defun nnimap-server-opened (&optional server)
 264   (and (nnoo-current-server-p 'nnimap server)
 265        nntp-server-buffer
 266        (gnus-buffer-live-p nntp-server-buffer)
 267        (nnimap-find-connection nntp-server-buffer)))
 268
 269 (defun nnimap-status-message (&optional server)
 270   nnimap-status-string)
 271
 272 (defun nnimap-request-article (article &optional group server to-buffer)
 273   (with-current-buffer nntp-server-buffer
 274     (let ((result (nnimap-possibly-change-group group server)))
 275       (when (stringp article)
 276         (setq article (nnimap-find-article-by-message-id group article)))
 277       (when (and result
 278                  article)
 279         (erase-buffer)
 280         (nnimap-with-process-buffer
 281          (erase-buffer)
 282          (setq result
 283                (nnimap-command
 284                 (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object))
 285                     "UID FETCH %d BODY.PEEK[]"
 286                   "UID FETCH %d RFC822.PEEK")
 287                 article)))
 288         (let ((buffer (nnimap-find-process-buffer (current-buffer))))
 289           (when (car result)
 290             (with-current-buffer to-buffer
 291               (insert-buffer-substring buffer)
 292               (goto-char (point-min))
 293               (let ((bytes (nnimap-get-length)))
 294                 (delete-region (line-beginning-position)
 295                                (progn (forward-line 1) (point)))
 296                 (goto-char (+ (point) bytes))
 297                 (delete-region (point) (point-max))
 298                 (nnheader-ms-strip-cr))
 299               t)))))))
 300
 301 (defun nnimap-request-group (group &optional server dont-check)
 302   (with-current-buffer nntp-server-buffer
 303     (let ((result (nnimap-possibly-change-group group server))
 304           articles)
 305       (when result
 306         (setq articles (nnimap-get-flags "1:*"))
 307         (erase-buffer)
 308         (insert
 309          (format
 310           "211 %d %d %d %S\n"
 311           (length articles)
 312           (or (caar articles) 0)
 313           (or (caar (last articles)) 0)
 314           group))
 315         t))))
 316
 317 (defun nnimap-get-flags (spec)
 318   (let ((articles nil)
 319         elems)
 320     (with-current-buffer (nnimap-buffer)
 321       (erase-buffer)
 322       (nnimap-wait-for-response (nnimap-send-command
 323                                  "UID FETCH %s FLAGS" spec))
 324       (goto-char (point-min))
 325       (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" nil t)
 326         (setq elems (nnimap-parse-line (match-string 1)))
 327         (push (cons (string-to-number (cadr (member "UID" elems)))
 328                     (cadr (member "FLAGS" elems)))
 329               articles)))
 330     (nreverse articles)))
 331
 332 (defun nnimap-close-group (group &optional server)
 333   t)
 334
 335 (deffoo nnimap-request-move-article (article group server accept-form
 336                                              &optional last internal-move-group)
 337   (when (nnimap-possibly-change-group group server)
 338     ;; If the move is internal (on the same server), just do it the easy
 339     ;; way.
 340     (let ((message-id (message-field-value "message-id")))
 341       (if internal-move-group
 342           (let ((result
 343                  (with-current-buffer (nnimap-buffer)
 344                    (nnimap-command "UID COPY %d %S"
 345                                    article
 346                                    (utf7-encode internal-move-group t)))))
 347             (when (car result)
 348               (nnimap-delete-article article)
 349               (cons internal-move-group
 350                     (nnimap-find-article-by-message-id
 351                      internal-move-group message-id))))
 352         (with-temp-buffer
 353           (let ((result (eval accept-form)))
 354             (when result
 355               (nnimap-delete-article article)
 356               result)))))))
 357
 358 (deffoo nnimap-request-expire-articles (articles group &optional server force)
 359   (cond
 360    ((not (nnimap-possibly-change-group group server))
 361     articles)
 362    (force
 363     (unless (nnimap-delete-article articles)
 364       (message "Article marked for deletion, but not expunged."))
 365     nil)
 366    (t
 367     articles)))
 368
 369 (defun nnimap-find-article-by-message-id (group message-id)
 370   (when (nnimap-possibly-change-group group nil)
 371     (with-current-buffer (nnimap-buffer)
 372       (let ((result
 373              (nnimap-command "UID SEARCH HEADER Message-Id %S" message-id))
 374             article)
 375         (when (car result)
 376           ;; Select the last instance of the message in the group.
 377           (and (setq article
 378                      (car (last (assoc "SEARCH" (cdr result)))))
 379                (string-to-number article)))))))
 380
 381 (defun nnimap-delete-article (articles)
 382   (with-current-buffer (nnimap-buffer)
 383     (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
 384                     (nnimap-article-ranges articles))
 385     (when (member "UIDPLUS" (nnimap-capabilities nnimap-object))
 386       (nnimap-send-command "UID EXPUNGE %s"
 387                            (nnimap-article-ranges articles))
 388       t)))
 389
 390 (deffoo nnimap-request-scan (&optional group server)
 391   (when (and (nnimap-possibly-change-group nil server)
 392              (equal group nnimap-inbox)
 393              nnimap-inbox
 394              nnimap-split-methods)
 395     (nnimap-split-incoming-mail)))
 396
 397 (defun nnimap-marks-to-flags (marks)
 398   (let (flags flag)
 399     (dolist (mark marks)
 400       (when (setq flag (cadr (assq mark nnimap-mark-alist)))
 401         (push flag flags)))
 402     flags))
 403
 404 (defun nnimap-request-set-mark (group actions &optional server)
 405   (when (nnimap-possibly-change-group group server)
 406     (let (sequence)
 407       (with-current-buffer (nnimap-find-process-buffer nntp-server-buffer)
 408         ;; Just send all the STORE commands without waiting for
 409         ;; response.  If they're successful, they're successful.
 410         (dolist (action actions)
 411           (destructuring-bind (range action marks) action
 412             (let ((flags (nnimap-marks-to-flags marks)))
 413               (when flags
 414                 (setq sequence (nnimap-send-command
 415                                 "UID STORE %s %sFLAGS.SILENT (%s)"
 416                                 (nnimap-article-ranges range)
 417                                 (if (eq action 'del)
 418                                     "-"
 419                                   "+")
 420                                 (mapconcat #'identity flags " ")))))))
 421         ;; Wait for the last command to complete to avoid later
 422         ;; syncronisation problems with the stream.
 423         (nnimap-wait-for-response sequence)))))
 424
 425 (deffoo nnimap-request-accept-article (group &optional server last)
 426   (when (nnimap-possibly-change-group nil server)
 427     (nnmail-check-syntax)
 428     (let ((message (buffer-string))
 429           (message-id (message-field-value "message-id"))
 430           sequence)
 431       (with-current-buffer nntp-server-buffer
 432         (nnimap-with-process-buffer
 433          (setq sequence (nnimap-send-command
 434                          "APPEND %S {%d}" (utf7-encode group t)
 435                          (length message)))
 436          (process-send-string (get-buffer-process (current-buffer)) message)
 437          (process-send-string (get-buffer-process (current-buffer)) "\r\n")
 438          (let ((result (nnimap-get-response sequence)))
 439            (when result
 440              (cons group
 441                    (nnimap-find-article-by-message-id group message-id)))))))))
 442
 443 (defun nnimap-add-cr ()
 444   (goto-char (point-min))
 445   (while (re-search-forward "\r?\n" nil t)
 446     (replace-match "\r\n" t t)))
 447
 448 (defun nnimap-get-groups ()
 449   (let ((result (nnimap-command "LIST \"\" \"*\""))
 450         groups)
 451     (when (car result)
 452       (dolist (line (cdr result))
 453         (when (and (equal (car line) "LIST")
 454                    (not (string-match "noselect" (caadr line))))
 455           (push (car (last line)) groups)))
 456       (nreverse groups))))
 457
 458 (defun nnimap-request-list (&optional server)
 459   (nnimap-possibly-change-group nil server)
 460   (with-current-buffer nntp-server-buffer
 461     (erase-buffer)
 462     (let ((groups
 463            (nnimap-with-process-buffer
 464             (nnimap-get-groups)))
 465           sequences responses)
 466       (when groups
 467         (nnimap-with-process-buffer
 468          (dolist (group groups)
 469            (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
 470                        group)
 471                  sequences))
 472          (nnimap-wait-for-response (caar sequences))
 473          (setq responses
 474                (nnimap-get-responses (mapcar #'car sequences))))
 475         (dolist (response responses)
 476           (let* ((sequence (car response))
 477                  (response (cadr response))
 478                  (group (cadr (assoc sequence sequences))))
 479             (when (and group
 480                        (equal (caar response) "OK"))
 481               (let ((uidnext (nnimap-find-parameter "UIDNEXT" response))
 482                     highest exists)
 483                 (dolist (elem response)
 484                   (when (equal (cadr elem) "EXISTS")
 485                     (setq exists (string-to-number (car elem)))))
 486                 (when uidnext
 487                   (setq highest (1- (string-to-number (car uidnext)))))
 488                 (cond
 489                  ((null highest)
 490                   (insert (format "%S 0 1 y\n" (utf7-decode group t))))
 491                  ((zerop exists)
 492                   ;; Empty group.
 493                   (insert (format "%S %d %d y\n"
 494                                   (utf7-decode group t) highest (1+ highest))))
 495                  (t
 496                   ;; Return the widest possible range.
 497                   (insert (format "%S %d 1 y\n" (utf7-decode group t)
 498                                   (or highest exists)))))))))
 499         t))))
 500
 501 (defun nnimap-retrieve-group-data-early (server infos)
 502   (when (nnimap-possibly-change-group nil server)
 503     (with-current-buffer (nnimap-buffer)
 504       ;; QRESYNC handling isn't implemented.
 505       (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object)))
 506             marks groups sequences)
 507         ;; Go through the infos and gather the data needed to know
 508         ;; what and how to request the data.
 509         (dolist (info infos)
 510           (setq marks (gnus-info-marks info))
 511           (push (list (gnus-group-real-name (gnus-info-group info))
 512                       (cdr (assq 'active marks))
 513                       (cdr (assq 'uid marks)))
 514                 groups))
 515         ;; Then request the data.
 516         (erase-buffer)
 517         (dolist (elem groups)
 518           (if (and qresyncp
 519                    (nth 2 elem))
 520               (push
 521                (list 'qresync
 522                      (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
 523                                           (car elem)
 524                                           (car (nth 2 elem))
 525                                           (cdr (nth 2 elem)))
 526                      nil
 527                      (car elem))
 528                sequences)
 529             (let ((start
 530                    (if (nth 1 elem)
 531                        ;; Fetch the last 100 flags.
 532                        (max 1 (- (cdr (nth 1 elem)) 100))
 533                      1)))
 534               (push (list (nnimap-send-command "EXAMINE %S" (car elem))
 535                           (nnimap-send-command "UID FETCH %d:* FLAGS" start)
 536                           start
 537                           (car elem))
 538                     sequences))))
 539         sequences))))
 540
 541 (defun nnimap-finish-retrieve-group-infos (server infos sequences)
 542   (when (nnimap-possibly-change-group nil server)
 543     (with-current-buffer (nnimap-buffer)
 544       ;; Wait for the final data to trickle in.
 545       (nnimap-wait-for-response (cadar sequences))
 546       ;; Now we should have all the data we need, no matter whether
 547       ;; we're QRESYNCING, fetching all the flags from scratch, or
 548       ;; just fetching the last 100 flags per group.
 549       (nnimap-update-infos (nnimap-flags-to-marks
 550                             (nnimap-parse-flags
 551                              (nreverse sequences)))
 552                            infos))))
 553
 554 (defun nnimap-update-infos (flags infos)
 555   (dolist (info infos)
 556     (let ((group (gnus-group-real-name (gnus-info-group info))))
 557       (nnimap-update-info info (cdr (assoc group flags))))))
 558
 559 (defun nnimap-update-info (info marks)
 560   (when marks
 561     (destructuring-bind (existing flags high low uidnext start-article) marks
 562       (let ((group (gnus-info-group info))
 563             (completep (and start-article
 564                             (= start-article 1))))
 565         ;; First set the active ranges based on high/low.
 566         (if completep
 567             (gnus-set-active group
 568                              (if high
 569                                  (cons low high)
 570                                ;; No articles in this group.
 571                                (cons (1- uidnext) uidnext)))
 572           (setcdr (gnus-active group) high))
 573         ;; Then update the list of read articles.
 574         (let* ((unread
 575                 (gnus-compress-sequence
 576                  (gnus-set-difference
 577                   (gnus-set-difference
 578                    existing
 579                    (cdr (assoc "\\Seen" flags)))
 580                   (cdr (assoc "\\Flagged" flags)))))
 581                (read (gnus-range-difference
 582                       (cons start-article high) unread)))
 583           (when (> start-article 1)
 584             (setq read
 585                   (gnus-range-nconcat
 586                    (gnus-sorted-range-intersection
 587                     (cons 1 start-article)
 588                     (gnus-info-read info))
 589                    read)))
 590           (gnus-info-set-read info read)
 591           ;; Update the marks.
 592           (setq marks (gnus-info-marks info))
 593           ;; Note the active level for the next run-through.
 594           (let ((active (assq 'active marks)))
 595             (if active
 596                 (setcdr active (gnus-active group))
 597               (push (cons 'active (gnus-active group)) marks)))
 598           (dolist (type (cdr nnimap-mark-alist))
 599             (let ((old-marks (assoc (car type) marks))
 600                   (new-marks (gnus-compress-sequence
 601                               (cdr (assoc (cadr type) flags)))))
 602               (setq marks (delq old-marks marks))
 603               (pop old-marks)
 604               (when (and old-marks
 605                          (> start-article 1))
 606                 (setq old-marks (gnus-range-difference
 607                                  (cons start-article high)
 608                                  old-marks))
 609                 (setq new-marks (gnus-range-nconcat old-marks new-marks)))
 610               (when new-marks
 611                 (push (cons (car type) new-marks) marks)))
 612             (gnus-info-set-marks info marks)))))))
 613
 614 (defun nnimap-flags-to-marks (groups)
 615   (let (data group totalp uidnext articles start-article mark)
 616     (dolist (elem groups)
 617       (setq group (car elem)
 618             uidnext (cadr elem)
 619             start-article (caddr elem)
 620             articles (cdddr elem))
 621       (let ((high (caar articles))
 622             marks low existing)
 623         (dolist (article articles)
 624           (setq low (car article))
 625           (push (car article) existing)
 626           (dolist (flag (cdr article))
 627             (setq mark (assoc flag marks))
 628             (if (not mark)
 629                 (push (list flag (car article)) marks)
 630               (setcdr mark (cons (car article) (cdr mark)))))
 631           (push (list group existing marks high low uidnext start-article)
 632                 data))))
 633     data))
 634
 635 (defun nnimap-parse-flags (sequences)
 636   (goto-char (point-min))
 637   (let (start end articles groups uidnext elems)
 638     (dolist (elem sequences)
 639       (destructuring-bind (group-sequence flag-sequence totalp group) elem
 640         ;; The EXAMINE was successful.
 641         (when (and (search-forward (format "\n%d OK " group-sequence) nil t)
 642                    (progn
 643                      (forward-line 1)
 644                      (setq start (point))
 645                      (if (re-search-backward "UIDNEXT \\([0-9]+\\)"
 646                                                (or end (point-min)) t)
 647                          (setq uidnext (string-to-number (match-string 1)))
 648                        (setq uidnext nil))
 649                      (goto-char start))
 650                    ;; The UID FETCH FLAGS was successful.
 651                    (search-forward (format "\n%d OK " flag-sequence) nil t))
 652           (setq end (point))
 653           (goto-char start)
 654           (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" end t)
 655             (setq elems (nnimap-parse-line (match-string 1)))
 656             (push (cons (string-to-number (cadr (member "UID" elems)))
 657                         (cadr (member "FLAGS" elems)))
 658                   articles))
 659           (push (nconc (list group uidnext totalp) articles) groups)
 660           (setq articles nil))))
 661     groups))
 662
 663 (defun nnimap-find-process-buffer (buffer)
 664   (cadr (assoc buffer nnimap-connection-alist)))
 665
 666 (defun nnimap-request-post (&optional server)
 667   (setq nnimap-status-string "Read-only server")
 668   nil)
 669
 670 (defun nnimap-possibly-change-group (group server)
 671   (when (and server
 672              (not (nnimap-server-opened server)))
 673     (nnimap-open-server server))
 674   (if (not group)
 675       t
 676     (with-current-buffer (nnimap-buffer)
 677       (if (equal group (nnimap-group nnimap-object))
 678           t
 679         (let ((result (nnimap-command "SELECT %S" (utf7-encode group t))))
 680           (when (car result)
 681             (setf (nnimap-group nnimap-object) group)
 682             result))))))
 683
 684 (defun nnimap-find-connection (buffer)
 685   "Find the connection delivering to BUFFER."
 686   (let ((entry (assoc buffer nnimap-connection-alist)))
 687     (when entry
 688       (if (and (buffer-name (cadr entry))
 689                (get-buffer-process (cadr entry))
 690                (memq (process-status (get-buffer-process (cadr entry)))
 691                      '(open run)))
 692           (get-buffer-process (cadr entry))
 693         (setq nnimap-connection-alist (delq entry nnimap-connection-alist))
 694         nil))))
 695
 696 (defvar nnimap-sequence 0)
 697
 698 (defun nnimap-send-command (&rest args)
 699   (process-send-string
 700    (get-buffer-process (current-buffer))
 701    (nnimap-log-command
 702     (format "%d %s\r\n"
 703             (incf nnimap-sequence)
 704             (apply #'format args))))
 705   nnimap-sequence)
 706
 707 (defun nnimap-log-command (command)
 708   (with-current-buffer (get-buffer-create "*imap log*")
 709     (goto-char (point-max))
 710     (insert (format-time-string "%H:%M:%S") " " command))
 711   command)
 712
 713 (defun nnimap-command (&rest args)
 714   (erase-buffer)
 715   (let* ((sequence (apply #'nnimap-send-command args))
 716          (response (nnimap-get-response sequence)))
 717     (if (equal (caar response) "OK")
 718         (cons t response)
 719       (nnheader-report 'nnimap "%s"
 720                        (mapconcat #'identity (car response) " "))
 721       nil)))
 722
 723 (defun nnimap-get-response (sequence)
 724   (nnimap-wait-for-response sequence)
 725   (nnimap-parse-response))
 726
 727 (defun nnimap-wait-for-response (sequence &optional messagep)
 728   (goto-char (point-max))
 729   (while (or (bobp)
 730              (progn
 731                (forward-line -1)
 732                (not (looking-at (format "^%d .*\n" sequence)))))
 733     (when messagep
 734       (message "Read %dKB" (/ (buffer-size) 1000)))
 735     (nnheader-accept-process-output (get-buffer-process (current-buffer)))
 736     (goto-char (point-max))))
 737
 738 (defun nnimap-parse-response ()
 739   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
 740         result)
 741     (dolist (line lines)
 742       (push (cdr (nnimap-parse-line line)) result))
 743     ;; Return the OK/error code first, and then all the "continuation
 744     ;; lines" afterwards.
 745     (cons (pop result)
 746           (nreverse result))))
 747
 748 ;; Parse an IMAP response line lightly.  They look like
 749 ;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse
 750 ;; the lines into a list of strings and lists of string.
 751 (defun nnimap-parse-line (line)
 752   (let (char result)
 753     (with-temp-buffer
 754       (insert line)
 755       (goto-char (point-min))
 756       (while (not (eobp))
 757         (if (eql (setq char (following-char)) ? )
 758             (forward-char 1)
 759           (push
 760            (cond
 761             ((eql char ?\[)
 762              (split-string (buffer-substring
 763                             (1+ (point)) (1- (search-forward "]")))))
 764             ((eql char ?\()
 765              (split-string (buffer-substring
 766                             (1+ (point)) (1- (search-forward ")")))))
 767             ((eql char ?\")
 768              (forward-char 1)
 769              (buffer-substring (point) (1- (search-forward "\""))))
 770             (t
 771              (buffer-substring (point) (if (search-forward " " nil t)
 772                                            (1- (point))
 773                                          (goto-char (point-max))))))
 774            result)))
 775       (nreverse result))))
 776
 777 (defun nnimap-last-response-string ()
 778   (save-excursion
 779     (forward-line 1)
 780     (let ((end (point)))
 781       (forward-line -1)
 782       (when (not (bobp))
 783         (forward-line -1)
 784         (while (and (not (bobp))
 785                     (eql (following-char) ?*))
 786           (forward-line -1))
 787         (unless (eql (following-char) ?*)
 788           (forward-line 1)))
 789       (buffer-substring (point) end))))
 790
 791 (defun nnimap-get-responses (sequences)
 792   (let (responses)
 793     (dolist (sequence sequences)
 794       (goto-char (point-min))
 795       (when (re-search-forward (format "^%d " sequence) nil t)
 796         (push (list sequence (nnimap-parse-response))
 797               responses)))
 798     responses))
 799
 800 (defvar nnimap-incoming-split-list nil)
 801
 802 (defun nnimap-fetch-inbox (articles)
 803   (erase-buffer)
 804   (nnimap-wait-for-response
 805    (nnimap-send-command
 806     "UID FETCH %s %s"
 807     (nnimap-article-ranges articles)
 808     (format "(UID %s%s)"
 809             (format
 810              (if (member "IMAP4REV1"
 811                          (nnimap-capabilities nnimap-object))
 812                  "BODY.PEEK[HEADER] BODY.PEEK"
 813                "RFC822.PEEK"))
 814             (if nnimap-split-download-body-default
 815                 ""
 816               "[1]")))
 817    t))
 818
 819 (defun nnimap-split-incoming-mail ()
 820   (with-current-buffer (nnimap-buffer)
 821     (let ((nnimap-incoming-split-list nil)
 822           (nnmail-split-methods nnimap-split-methods)
 823           (nnmail-inhibit-default-split-group t)
 824           (groups (nnimap-get-groups))
 825           new-articles)
 826       (erase-buffer)
 827       (nnimap-command "SELECT %S" nnimap-inbox)
 828       (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*")))
 829       (when new-articles
 830         (nnimap-fetch-inbox new-articles)
 831         (nnimap-transform-split-mail)
 832         (nnheader-ms-strip-cr)
 833         (nnmail-cache-open)
 834         (nnmail-split-incoming (current-buffer)
 835                                #'nnimap-save-mail-spec
 836                                nil nil
 837                                #'nnimap-dummy-active-number)
 838         (when nnimap-incoming-split-list
 839           (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
 840                 sequences)
 841             ;; Create any groups that doesn't already exist on the
 842             ;; server first.
 843             (dolist (spec specs)
 844               (unless (member (car spec) groups)
 845                 (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
 846             ;; Then copy over all the messages.
 847             (erase-buffer)
 848             (dolist (spec specs)
 849               (let ((group (car spec))
 850                     (ranges (cdr spec)))
 851                 (push (list (nnimap-send-command "UID COPY %s %S"
 852                                                  (nnimap-article-ranges ranges)
 853                                                  (utf7-encode group t))
 854                             ranges)
 855                       sequences)))
 856             ;; Wait for the last COPY response...
 857             (when sequences
 858               (nnimap-wait-for-response (caar sequences))
 859               ;; And then mark the successful copy actions as deleted,
 860               ;; and possibly expunge them.
 861               (nnimap-mark-and-expunge-incoming
 862                (nnimap-parse-copied-articles sequences)))))))))
 863
 864 (defun nnimap-mark-and-expunge-incoming (range)
 865   (when range
 866     (setq range (nnimap-article-ranges range))
 867     (nnimap-send-command
 868      "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)
 869     (cond
 870      ;; If the server supports it, we now delete the message we have
 871      ;; just copied over.
 872      ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
 873       (nnimap-send-command "UID EXPUNGE %s" range))
 874      ;; If it doesn't support UID EXPUNGE, then we only expunge if the
 875      ;; user has configured it.
 876      (nnimap-expunge-inbox
 877       (nnimap-send-command "EXPUNGE")))))
 878
 879 (defun nnimap-parse-copied-articles (sequences)
 880   (let (sequence copied range)
 881     (goto-char (point-min))
 882     (while (re-search-forward "^\\([0-9]+\\) OK " nil t)
 883       (setq sequence (string-to-number (match-string 1)))
 884       (when (setq range (cadr (assq sequence sequences)))
 885         (push (gnus-uncompress-range range) copied)))
 886     (gnus-compress-sequence (sort (apply #'nconc copied) #'<))))
 887
 888 (defun nnimap-new-articles (flags)
 889   (let (new)
 890     (dolist (elem flags)
 891       (when (or (null (cdr elem))
 892                 (and (not (member "\\Deleted" (cdr elem)))
 893                      (not (member "\\Seen" (cdr elem)))))
 894         (push (car elem) new)))
 895     (gnus-compress-sequence (nreverse new))))
 896
 897 (defun nnimap-make-split-specs (list)
 898   (let ((specs nil)
 899         entry)
 900     (dolist (elem list)
 901       (destructuring-bind (article spec) elem
 902         (dolist (group (delete nil (mapcar #'car spec)))
 903           (unless (setq entry (assoc group specs))
 904             (push (setq entry (list group)) specs))
 905           (setcdr entry (cons article (cdr entry))))))
 906     (dolist (entry specs)
 907       (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<))))
 908     specs))
 909
 910 (defun nnimap-transform-split-mail ()
 911   (goto-char (point-min))
 912   (let (article bytes)
 913     (block nil
 914       (while (not (eobp))
 915         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 916           (delete-region (point) (progn (forward-line 1) (point)))
 917           (when (eobp)
 918             (return)))
 919         (setq article (match-string 1)
 920               bytes (nnimap-get-length))
 921         (delete-region (line-beginning-position) (line-end-position))
 922         ;; Insert MMDF separator, and a way to remember what this
 923         ;; article UID is.
 924         (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article))
 925         (forward-char (1+ bytes))
 926         (setq bytes (nnimap-get-length))
 927         (delete-region (line-beginning-position) (line-end-position))
 928         (forward-char (1+ bytes))
 929         (delete-region (line-beginning-position) (line-end-position))))))
 930
 931 (defun nnimap-dummy-active-number (group &optional server)
 932   1)
 933
 934 (defun nnimap-save-mail-spec (group-art &optional server full-nov)
 935   (let (article)
 936     (goto-char (point-min))
 937     (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
 938         (error "Invalid nnimap mail")
 939       (setq article (string-to-number (match-string 1))))
 940     (push (list article group-art)
 941           nnimap-incoming-split-list)))
 942
 943 (provide 'nnimap)
 944
 945 ;;; nnimap.el ends here