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