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