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