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