emacs: Add `notmuch-show-multipart/alternative-discouraged'.
[notmuch] / emacs / notmuch-show.el
1 ;; notmuch-show.el --- displaying notmuch forests.
2 ;;
3 ;; Copyright © Carl Worth
4 ;; Copyright © David Edmondson
5 ;;
6 ;; This file is part of Notmuch.
7 ;;
8 ;; Notmuch is free software: you can redistribute it and/or modify it
9 ;; under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
12 ;;
13 ;; Notmuch is distributed in the hope that it will be useful, but
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16 ;; General Public License for more details.
17 ;;
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with Notmuch.  If not, see <http://www.gnu.org/licenses/>.
20 ;;
21 ;; Authors: Carl Worth <cworth@cworth.org>
22 ;;          David Edmondson <dme@dme.org>
23
24 (eval-when-compile (require 'cl))
25 (require 'mm-view)
26 (require 'message)
27 (require 'mm-decode)
28 (require 'mailcap)
29
30 (require 'notmuch-lib)
31 (require 'notmuch-query)
32 (require 'notmuch-wash)
33 (require 'notmuch-mua)
34
35 (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
36 (declare-function notmuch-fontify-headers "notmuch" nil)
37 (declare-function notmuch-select-tag-with-completion "notmuch" (prompt &rest search-terms))
38 (declare-function notmuch-search-show-thread "notmuch" nil)
39
40 (defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date")
41   "Headers that should be shown in a message, in this order.
42
43 For an open message, all of these headers will be made visible
44 according to `notmuch-message-headers-visible' or can be toggled
45 with `notmuch-show-toggle-headers'. For a closed message, only
46 the first header in the list will be visible."
47   :group 'notmuch
48   :type '(repeat string))
49
50 (defcustom notmuch-message-headers-visible t
51   "Should the headers be visible by default?
52
53 If this value is non-nil, then all of the headers defined in
54 `notmuch-message-headers' will be visible by default in the display
55 of each message. Otherwise, these headers will be hidden and
56 `notmuch-show-toggle-headers' can be used to make the visible for
57 any given message."
58   :group 'notmuch
59   :type 'boolean)
60
61 (defcustom notmuch-show-relative-dates t
62   "Display relative dates in the message summary line."
63   :group 'notmuch
64   :type 'boolean)
65
66 (defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers)
67   "A list of functions called to decorate the headers listed in
68 `notmuch-message-headers'.")
69
70 (defcustom notmuch-show-hook nil
71   "Functions called after populating a `notmuch-show' buffer."
72   :group 'notmuch
73   :type 'hook)
74
75 (defcustom notmuch-show-insert-text/plain-hook '(notmuch-wash-excerpt-citations)
76   "Functions used to improve the display of text/plain parts."
77   :group 'notmuch
78   :type 'hook
79   :options '(notmuch-wash-convert-inline-patch-to-part
80              notmuch-wash-wrap-long-lines
81              notmuch-wash-tidy-citations
82              notmuch-wash-elide-blank-lines
83              notmuch-wash-excerpt-citations))
84
85 (defmacro with-current-notmuch-show-message (&rest body)
86   "Evaluate body with current buffer set to the text of current message"
87   `(save-excursion
88      (let ((id (notmuch-show-get-message-id)))
89        (let ((buf (generate-new-buffer (concat "*notmuch-msg-" id "*"))))
90          (with-current-buffer buf
91             (call-process notmuch-command nil t nil "show" "--format=raw" id)
92            ,@body)
93          (kill-buffer buf)))))
94
95 (defun notmuch-show-view-all-mime-parts ()
96   "Use external viewers to view all attachments from the current message."
97   (interactive)
98   (with-current-notmuch-show-message
99    ; We ovverride the mm-inline-media-tests to indicate which message
100    ; parts are already sufficiently handled by the original
101    ; presentation of the message in notmuch-show mode. These parts
102    ; will be inserted directly into the temporary buffer of
103    ; with-current-notmuch-show-message and silently discarded.
104    ;
105    ; Any MIME part not explicitly mentioned here will be handled by an
106    ; external viewer as configured in the various mailcap files.
107    (let ((mm-inline-media-tests '(
108                                   ("text/.*" ignore identity)
109                                   ("application/pgp-signature" ignore identity)
110                                   ("multipart/alternative" ignore identity)
111                                   ("multipart/mixed" ignore identity)
112                                   ("multipart/related" ignore identity)
113                                  )))
114      (mm-display-parts (mm-dissect-buffer)))))
115
116 (defun notmuch-foreach-mime-part (function mm-handle)
117   (cond ((stringp (car mm-handle))
118          (dolist (part (cdr mm-handle))
119            (notmuch-foreach-mime-part function part)))
120         ((bufferp (car mm-handle))
121          (funcall function mm-handle))
122         (t (dolist (part mm-handle)
123              (notmuch-foreach-mime-part function part)))))
124
125 (defun notmuch-count-attachments (mm-handle)
126   (let ((count 0))
127     (notmuch-foreach-mime-part
128      (lambda (p)
129        (let ((disposition (mm-handle-disposition p)))
130          (and (listp disposition)
131               (or (equal (car disposition) "attachment")
132                   (and (equal (car disposition) "inline")
133                        (assq 'filename disposition)))
134               (incf count))))
135      mm-handle)
136     count))
137
138 (defun notmuch-save-attachments (mm-handle &optional queryp)
139   (notmuch-foreach-mime-part
140    (lambda (p)
141      (let ((disposition (mm-handle-disposition p)))
142        (and (listp disposition)
143             (or (equal (car disposition) "attachment")
144                 (and (equal (car disposition) "inline")
145                      (assq 'filename disposition)))
146             (or (not queryp)
147                 (y-or-n-p
148                  (concat "Save '" (cdr (assq 'filename disposition)) "' ")))
149             (mm-save-part p))))
150    mm-handle))
151
152 (defun notmuch-show-save-attachments ()
153   "Save all attachments from the current message."
154   (interactive)
155   (with-current-notmuch-show-message
156    (let ((mm-handle (mm-dissect-buffer)))
157      (notmuch-save-attachments
158       mm-handle (> (notmuch-count-attachments mm-handle) 1))))
159   (message "Done"))
160
161 (defun notmuch-show-fontify-header ()
162   (let ((face (cond
163                ((looking-at "[Tt]o:")
164                 'message-header-to)
165                ((looking-at "[Bb]?[Cc][Cc]:")
166                 'message-header-cc)
167                ((looking-at "[Ss]ubject:")
168                 'message-header-subject)
169                ((looking-at "[Ff]rom:")
170                 'message-header-from)
171                (t
172                 'message-header-other))))
173
174     (overlay-put (make-overlay (point) (re-search-forward ":"))
175                  'face 'message-header-name)
176     (overlay-put (make-overlay (point) (re-search-forward ".*$"))
177                  'face face)))
178
179 (defun notmuch-show-colour-headers ()
180   "Apply some colouring to the current headers."
181   (goto-char (point-min))
182   (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:")
183     (notmuch-show-fontify-header)
184     (forward-line)))
185
186 (defun notmuch-show-spaces-n (n)
187   "Return a string comprised of `n' spaces."
188   (make-string n ? ))
189
190 (defun notmuch-show-update-tags (tags)
191   "Update the displayed tags of the current message."
192   (save-excursion
193     (goto-char (notmuch-show-message-top))
194     (if (re-search-forward "(\\([^()]*\\))$" (line-end-position) t)
195         (let ((inhibit-read-only t))
196           (replace-match (concat "("
197                                  (propertize (mapconcat 'identity tags " ")
198                                              'face 'notmuch-tag-face)
199                                  ")"))))))
200
201 (defun notmuch-show-insert-headerline (headers date tags depth)
202   "Insert a notmuch style headerline based on HEADERS for a
203 message at DEPTH in the current thread."
204   (let ((start (point)))
205     (insert (notmuch-show-spaces-n depth)
206             (plist-get headers :From)
207             " ("
208             date
209             ") ("
210             (propertize (mapconcat 'identity tags " ")
211                         'face 'notmuch-tag-face)
212             ")\n")
213     (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face)))
214
215 (defun notmuch-show-insert-header (header header-value)
216   "Insert a single header."
217   (insert header ": " header-value "\n"))
218
219 (defun notmuch-show-insert-headers (headers)
220   "Insert the headers of the current message."
221   (let ((start (point)))
222     (mapc '(lambda (header)
223              (let* ((header-symbol (intern (concat ":" header)))
224                     (header-value (plist-get headers header-symbol)))
225                (if (and header-value
226                         (not (string-equal "" header-value)))
227                    (notmuch-show-insert-header header header-value))))
228           notmuch-message-headers)
229     (save-excursion
230       (save-restriction
231         (narrow-to-region start (point-max))
232         (run-hooks 'notmuch-show-markup-headers-hook)))))
233
234 (define-button-type 'notmuch-show-part-button-type
235   'action 'notmuch-show-part-button-action
236   'follow-link t
237   'face 'message-mml)
238
239 (defun notmuch-show-insert-part-header (nth content-type declared-type &optional name comment)
240   (insert-button
241    (concat "[ "
242            (if name (concat name ": ") "")
243            declared-type
244            (if (not (string-equal declared-type content-type))
245                (concat " (as " content-type ")")
246              "")
247            (or comment "")
248            " ]\n")
249    :type 'notmuch-show-part-button-type
250    :notmuch-part nth
251    :notmuch-filename name))
252
253 ;; Functions handling particular MIME parts.
254
255 (defun notmuch-show-save-part (message-id nth &optional filename)
256   (with-temp-buffer
257     ;; Always acquires the part via `notmuch part', even if it is
258     ;; available in the JSON output.
259     (insert (notmuch-show-get-bodypart-internal message-id nth))
260     (let ((file (read-file-name
261                  "Filename to save as: "
262                  (or mailcap-download-directory "~/")
263                  nil nil
264                  filename))
265           (require-final-newline nil)
266           (coding-system-for-write 'no-conversion))
267       (write-region (point-min) (point-max) file))))
268
269 (defun notmuch-show-mm-display-part-inline (msg part content-type content)
270   "Use the mm-decode/mm-view functions to display a part in the
271 current buffer, if possible."
272   (let ((display-buffer (current-buffer)))
273     (with-temp-buffer
274       (insert content)
275       (let ((handle (mm-make-handle (current-buffer) (list content-type))))
276         (set-buffer display-buffer)
277         (if (and (mm-inlinable-p handle)
278                  (mm-inlined-p handle))
279             (progn
280               (mm-display-part handle)
281               t)
282           nil)))))
283
284 (defvar notmuch-show-multipart/alternative-discouraged
285   '(
286     ;; Avoid HTML parts.
287     "text/html"
288     ;; multipart/related usually contain a text/html part and some associated graphics.
289     "multipart/related"
290     ))
291
292 (defun notmuch-show-multipart/*-to-list (part)
293   (mapcar '(lambda (inner-part) (plist-get inner-part :content-type))
294           (plist-get part :content)))
295
296 (defun notmuch-show-multipart/alternative-choose (types)
297   ;; Based on `mm-preferred-alternative-precedence'.
298   (let ((seq types))
299     (dolist (pref (reverse notmuch-show-multipart/alternative-discouraged))
300       (dolist (elem (copy-sequence seq))
301         (when (string-match pref elem)
302           (setq seq (nconc (delete elem seq) (list elem))))))
303     seq))
304
305 (defun notmuch-show-insert-part-multipart/alternative (msg part content-type nth depth declared-type)
306   (notmuch-show-insert-part-header nth declared-type content-type nil)
307   (let ((chosen-type (car (notmuch-show-multipart/alternative-choose (notmuch-show-multipart/*-to-list part))))
308         (inner-parts (plist-get part :content)))
309     ;; This inserts all parts of the chosen type rather than just one,
310     ;; but it's not clear that this is the wrong thing to do - which
311     ;; should be chosen if there are more than one that match?
312     (mapc (lambda (inner-part)
313             (let ((inner-type (plist-get inner-part :content-type)))
314               (if (string= chosen-type inner-type)
315                   (notmuch-show-insert-bodypart msg inner-part depth)
316                 (notmuch-show-insert-part-header (plist-get inner-part :id) inner-type inner-type nil " (not shown)"))))
317           inner-parts))
318   t)
319
320 (defun notmuch-show-insert-part-multipart/* (msg part content-type nth depth declared-type)
321   (let ((inner-parts (plist-get part :content)))
322     (notmuch-show-insert-part-header nth declared-type content-type nil)
323     ;; Show all of the parts.
324     (mapc (lambda (inner-part)
325             (notmuch-show-insert-bodypart msg inner-part depth))
326           inner-parts))
327   t)
328
329 (defun notmuch-show-insert-part-message/rfc822 (msg part content-type nth depth declared-type)
330   (let* ((message-part (plist-get part :content))
331          (inner-parts (plist-get message-part :content)))
332     (notmuch-show-insert-part-header nth declared-type content-type nil)
333     ;; Override `notmuch-message-headers' to force `From' to be
334     ;; displayed.
335     (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date")))
336       (notmuch-show-insert-headers (plist-get part :headers)))
337     ;; Blank line after headers to be compatible with the normal
338     ;; message display.
339     (insert "\n")
340
341     ;; Show all of the parts.
342     (mapc (lambda (inner-part)
343             (notmuch-show-insert-bodypart msg inner-part depth))
344           inner-parts))
345   t)
346
347 (defun notmuch-show-insert-part-text/plain (msg part content-type nth depth declared-type)
348   (let ((start (point)))
349     ;; If this text/plain part is not the first part in the message,
350     ;; insert a header to make this clear.
351     (if (> nth 1)
352         (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename)))
353     (insert (notmuch-show-get-bodypart-content msg part nth))
354     (save-excursion
355       (save-restriction
356         (narrow-to-region start (point-max))
357         (run-hook-with-args 'notmuch-show-insert-text/plain-hook depth))))
358   t)
359
360 (defun notmuch-show-insert-part-application/octet-stream (msg part content-type nth depth declared-type)
361   ;; If we can deduce a MIME type from the filename of the attachment,
362   ;; do so and pass it on to the handler for that type.
363   (if (plist-get part :filename)
364       (let ((extension (file-name-extension (plist-get part :filename)))
365             mime-type)
366         (if extension
367             (progn
368               (mailcap-parse-mimetypes)
369               (setq mime-type (mailcap-extension-to-mime extension))
370               (if (and mime-type
371                        (not (string-equal mime-type "application/octet-stream")))
372                   (notmuch-show-insert-bodypart-internal msg part mime-type nth depth content-type)
373                 nil))
374           nil))))
375
376 (defun notmuch-show-insert-part-*/* (msg part content-type nth depth declared-type)
377   ;; This handler _must_ succeed - it is the handler of last resort.
378   (notmuch-show-insert-part-header nth content-type declared-type (plist-get part :filename))
379   (let ((content (notmuch-show-get-bodypart-content msg part nth)))
380     (if content
381         (notmuch-show-mm-display-part-inline msg part content-type content)))
382   t)
383
384 ;; Functions for determining how to handle MIME parts.
385
386 (defun notmuch-show-split-content-type (content-type)
387   (split-string content-type "/"))
388
389 (defun notmuch-show-handlers-for (content-type)
390   "Return a list of content handlers for a part of type CONTENT-TYPE."
391   (let (result)
392     (mapc (lambda (func)
393             (if (functionp func)
394                 (push func result)))
395           ;; Reverse order of prefrence.
396           (list (intern (concat "notmuch-show-insert-part-*/*"))
397                 (intern (concat
398                          "notmuch-show-insert-part-"
399                          (car (notmuch-show-split-content-type content-type))
400                          "/*"))
401                 (intern (concat "notmuch-show-insert-part-" content-type))))
402     result))
403
404 ;; Helper for parts which are generally not included in the default
405 ;; JSON output.
406
407 (defun notmuch-show-get-bodypart-internal (message-id part-number)
408   (with-temp-buffer
409     (let ((coding-system-for-read 'no-conversion))
410       (call-process notmuch-command nil t nil
411                     "part" (format "--part=%s" part-number) message-id)
412       (buffer-string))))
413
414 (defun notmuch-show-get-bodypart-content (msg part nth)
415   (or (plist-get part :content)
416       (notmuch-show-get-bodypart-internal (concat "id:" (plist-get msg :id)) nth)))
417
418 ;; \f
419
420 (defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth declared-type)
421   (let ((handlers (notmuch-show-handlers-for content-type)))
422     ;; Run the content handlers until one of them returns a non-nil
423     ;; value.
424     (while (and handlers
425                 (not (funcall (car handlers) msg part content-type nth depth declared-type)))
426       (setq handlers (cdr handlers))))
427   t)
428
429 (defun notmuch-show-insert-bodypart (msg part depth)
430   "Insert the body part PART at depth DEPTH in the current thread."
431   (let ((content-type (downcase (plist-get part :content-type)))
432         (nth (plist-get part :id)))
433     (notmuch-show-insert-bodypart-internal msg part content-type nth depth content-type))
434   ;; Some of the body part handlers leave point somewhere up in the
435   ;; part, so we make sure that we're down at the end.
436   (goto-char (point-max))
437   ;; Ensure that the part ends with a carriage return.
438   (if (not (bolp))
439       (insert "\n")))
440
441 (defun notmuch-show-insert-body (msg body depth)
442   "Insert the body BODY at depth DEPTH in the current thread."
443   (mapc '(lambda (part) (notmuch-show-insert-bodypart msg part depth)) body))
444
445 (defun notmuch-show-make-symbol (type)
446   (make-symbol (concat "notmuch-show-" type)))
447
448 (defun notmuch-show-strip-re (string)
449   (replace-regexp-in-string "\\([Rr]e: *\\)+" "" string))
450
451 (defvar notmuch-show-previous-subject "")
452 (make-variable-buffer-local 'notmuch-show-previous-subject)
453
454 (defun notmuch-show-insert-msg (msg depth)
455   "Insert the message MSG at depth DEPTH in the current thread."
456   (let* ((headers (plist-get msg :headers))
457          ;; Indentation causes the buffer offset of the start/end
458          ;; points to move, so we must use markers.
459          message-start message-end
460          content-start content-end
461          headers-start headers-end
462          body-start body-end
463          (headers-invis-spec (notmuch-show-make-symbol "header"))
464          (message-invis-spec (notmuch-show-make-symbol "message"))
465          (bare-subject (notmuch-show-strip-re (plist-get headers :Subject))))
466
467     ;; Set `buffer-invisibility-spec' to `nil' (a list), otherwise
468     ;; removing items from `buffer-invisibility-spec' (which is what
469     ;; `notmuch-show-headers-visible' and
470     ;; `notmuch-show-message-visible' do) is a no-op and has no
471     ;; effect. This caused threads with only matching messages to have
472     ;; those messages hidden initially because
473     ;; `buffer-invisibility-spec' stayed `t'.
474     ;;
475     ;; This needs to be set here (rather than just above the call to
476     ;; `notmuch-show-headers-visible') because some of the part
477     ;; rendering or body washing functions
478     ;; (e.g. `notmuch-wash-text/plain-citations') manipulate
479     ;; `buffer-invisibility-spec').
480     (when (eq buffer-invisibility-spec t)
481       (setq buffer-invisibility-spec nil))
482
483     (setq message-start (point-marker))
484
485     (notmuch-show-insert-headerline headers
486                                     (or (if notmuch-show-relative-dates
487                                             (plist-get msg :date_relative)
488                                           nil)
489                                         (plist-get headers :Date))
490                                     (plist-get msg :tags) depth)
491
492     (setq content-start (point-marker))
493
494     ;; Set `headers-start' to point after the 'Subject:' header to be
495     ;; compatible with the existing implementation. This just sets it
496     ;; to after the first header.
497     (notmuch-show-insert-headers headers)
498     ;; Headers should include a blank line (backwards compatibility).
499     (insert "\n")
500     (save-excursion
501       (goto-char content-start)
502       ;; If the subject of this message is the same as that of the
503       ;; previous message, don't display it when this message is
504       ;; collapsed.
505       (when (not (string= notmuch-show-previous-subject
506                           bare-subject))
507         (forward-line 1))
508       (setq headers-start (point-marker)))
509     (setq headers-end (point-marker))
510
511     (setq notmuch-show-previous-subject bare-subject)
512
513     (setq body-start (point-marker))
514     (notmuch-show-insert-body msg (plist-get msg :body) depth)
515     ;; Ensure that the body ends with a newline.
516     (if (not (bolp))
517         (insert "\n"))
518     (setq body-end (point-marker))
519     (setq content-end (point-marker))
520
521     ;; Indent according to the depth in the thread.
522     (indent-rigidly content-start content-end depth)
523
524     (setq message-end (point-max-marker))
525
526     ;; Save the extents of this message over the whole text of the
527     ;; message.
528     (put-text-property message-start message-end :notmuch-message-extent (cons message-start message-end))
529
530     (plist-put msg :headers-invis-spec headers-invis-spec)
531     (overlay-put (make-overlay headers-start headers-end) 'invisible headers-invis-spec)
532
533     (plist-put msg :message-invis-spec message-invis-spec)
534     (overlay-put (make-overlay body-start body-end) 'invisible message-invis-spec)
535
536     ;; Save the properties for this message. Currently this saves the
537     ;; entire message (augmented it with other stuff), which seems
538     ;; like overkill. We might save a reduced subset (for example, not
539     ;; the content).
540     (notmuch-show-set-message-properties msg)
541
542     ;; Set header visibility.
543     (notmuch-show-headers-visible msg notmuch-message-headers-visible)
544
545     ;; Message visibility depends on whether it matched the search
546     ;; criteria.
547     (notmuch-show-message-visible msg (plist-get msg :match))))
548
549 (defun notmuch-show-insert-tree (tree depth)
550   "Insert the message tree TREE at depth DEPTH in the current thread."
551   (let ((msg (car tree))
552         (replies (cadr tree)))
553     (notmuch-show-insert-msg msg depth)
554     (notmuch-show-insert-thread replies (1+ depth))))
555
556 (defun notmuch-show-insert-thread (thread depth)
557   "Insert the thread THREAD at depth DEPTH in the current forest."
558   (mapc '(lambda (tree) (notmuch-show-insert-tree tree depth)) thread))
559
560 (defun notmuch-show-insert-forest (forest)
561   "Insert the forest of threads FOREST."
562   (mapc '(lambda (thread) (notmuch-show-insert-thread thread 0)) forest))
563
564 (defvar notmuch-show-parent-buffer nil)
565
566 ;;;###autoload
567 (defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name)
568   "Run \"notmuch show\" with the given thread ID and display results.
569
570 The optional PARENT-BUFFER is the notmuch-search buffer from
571 which this notmuch-show command was executed, (so that the
572 next thread from that buffer can be show when done with this
573 one).
574
575 The optional QUERY-CONTEXT is a notmuch search term. Only
576 messages from the thread matching this search term are shown if
577 non-nil.
578
579 The optional BUFFER-NAME provides the neame of the buffer in
580 which the message thread is shown. If it is nil (which occurs
581 when the command is called interactively) the argument to the
582 function is used. "
583   (interactive "sNotmuch show: ")
584   (let ((buffer (get-buffer-create (generate-new-buffer-name
585                                     (or buffer-name
586                                         (concat "*notmuch-" thread-id "*")))))
587         (inhibit-read-only t))
588     (switch-to-buffer buffer)
589     (notmuch-show-mode)
590     (set (make-local-variable 'notmuch-show-parent-buffer) parent-buffer)
591     (erase-buffer)
592     (goto-char (point-min))
593     (save-excursion
594       (let* ((basic-args (list thread-id))
595              (args (if query-context
596                        (append (list "\'") basic-args (list "and (" query-context ")\'"))
597                      (append (list "\'") basic-args (list "\'")))))
598         (notmuch-show-insert-forest (notmuch-query-get-threads args))
599         ;; If the query context reduced the results to nothing, run
600         ;; the basic query.
601         (when (and (eq (buffer-size) 0)
602                    query-context)
603           (notmuch-show-insert-forest
604            (notmuch-query-get-threads basic-args))))
605
606       ;; Enable buttonisation of URLs and email addresses in the
607       ;; buffer.
608       (goto-address-mode t)
609       ;; Act on visual lines rather than logical lines.
610       (visual-line-mode t)
611
612       (run-hooks 'notmuch-show-hook))
613
614     ;; Move straight to the first open message
615     (if (not (notmuch-show-message-visible-p))
616         (notmuch-show-next-open-message))
617
618     ;; Set the header line to the subject of the first open message.
619     (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject)))
620
621     (notmuch-show-mark-read)))
622
623 (defvar notmuch-show-stash-map
624   (let ((map (make-sparse-keymap)))
625     (define-key map "c" 'notmuch-show-stash-cc)
626     (define-key map "d" 'notmuch-show-stash-date)
627     (define-key map "F" 'notmuch-show-stash-filename)
628     (define-key map "f" 'notmuch-show-stash-from)
629     (define-key map "i" 'notmuch-show-stash-message-id)
630     (define-key map "s" 'notmuch-show-stash-subject)
631     (define-key map "T" 'notmuch-show-stash-tags)
632     (define-key map "t" 'notmuch-show-stash-to)
633     map)
634   "Submap for stash commands")
635 (fset 'notmuch-show-stash-map notmuch-show-stash-map)
636
637 (defvar notmuch-show-mode-map
638       (let ((map (make-sparse-keymap)))
639         (define-key map "?" 'notmuch-help)
640         (define-key map "q" 'notmuch-kill-this-buffer)
641         (define-key map (kbd "<C-tab>") 'widget-backward)
642         (define-key map (kbd "M-TAB") 'notmuch-show-previous-button)
643         (define-key map (kbd "<backtab>") 'notmuch-show-previous-button)
644         (define-key map (kbd "TAB") 'notmuch-show-next-button)
645         (define-key map "s" 'notmuch-search)
646         (define-key map "m" 'notmuch-mua-mail)
647         (define-key map "f" 'notmuch-show-forward-message)
648         (define-key map "r" 'notmuch-show-reply)
649         (define-key map "|" 'notmuch-show-pipe-message)
650         (define-key map "w" 'notmuch-show-save-attachments)
651         (define-key map "V" 'notmuch-show-view-raw-message)
652         (define-key map "v" 'notmuch-show-view-all-mime-parts)
653         (define-key map "c" 'notmuch-show-stash-map)
654         (define-key map "h" 'notmuch-show-toggle-headers)
655         (define-key map "-" 'notmuch-show-remove-tag)
656         (define-key map "+" 'notmuch-show-add-tag)
657         (define-key map "x" 'notmuch-show-archive-thread-then-exit)
658         (define-key map "a" 'notmuch-show-archive-thread)
659         (define-key map "N" 'notmuch-show-next-message)
660         (define-key map "P" 'notmuch-show-previous-message)
661         (define-key map "n" 'notmuch-show-next-open-message)
662         (define-key map "p" 'notmuch-show-previous-open-message)
663         (define-key map (kbd "DEL") 'notmuch-show-rewind)
664         (define-key map " " 'notmuch-show-advance-and-archive)
665         (define-key map (kbd "M-RET") 'notmuch-show-open-or-close-all)
666         (define-key map (kbd "RET") 'notmuch-show-toggle-message)
667         map)
668       "Keymap for \"notmuch show\" buffers.")
669 (fset 'notmuch-show-mode-map notmuch-show-mode-map)
670
671 (defun notmuch-show-mode ()
672   "Major mode for viewing a thread with notmuch.
673
674 This buffer contains the results of the \"notmuch show\" command
675 for displaying a single thread of email from your email archives.
676
677 By default, various components of email messages, (citations,
678 signatures, already-read messages), are hidden. You can make
679 these parts visible by clicking with the mouse button or by
680 pressing RET after positioning the cursor on a hidden part, (for
681 which \\[notmuch-show-next-button] and \\[notmuch-show-previous-button] are helpful).
682
683 Reading the thread sequentially is well-supported by pressing
684 \\[notmuch-show-advance-and-archive]. This will scroll the current message (if necessary), advance
685 to the next message, or advance to the next thread (if already on
686 the last message of a thread).
687
688 Other commands are available to read or manipulate the thread
689 more selectively, (such as '\\[notmuch-show-next-message]' and '\\[notmuch-show-previous-message]' to advance to messages
690 without removing any tags, and '\\[notmuch-show-archive-thread]' to archive an entire thread
691 without scrolling through with \\[notmuch-show-advance-and-archive]).
692
693 You can add or remove arbitary tags from the current message with
694 '\\[notmuch-show-add-tag]' or '\\[notmuch-show-remove-tag]'.
695
696 All currently available key bindings:
697
698 \\{notmuch-show-mode-map}"
699   (interactive)
700   (kill-all-local-variables)
701   (use-local-map notmuch-show-mode-map)
702   (setq major-mode 'notmuch-show-mode
703         mode-name "notmuch-show")
704   (setq buffer-read-only t))
705
706 (defun notmuch-show-move-to-message-top ()
707   (goto-char (notmuch-show-message-top)))
708
709 (defun notmuch-show-move-to-message-bottom ()
710   (goto-char (notmuch-show-message-bottom)))
711
712 (defun notmuch-show-message-adjust ()
713   (recenter 0))
714
715 ;; Movement related functions.
716
717 ;; There's some strangeness here where a text property applied to a
718 ;; region a->b is not found when point is at b. We walk backwards
719 ;; until finding the property.
720 (defun notmuch-show-message-extent ()
721   (let (r)
722     (save-excursion
723       (while (not (setq r (get-text-property (point) :notmuch-message-extent)))
724         (backward-char)))
725     r))
726
727 (defun notmuch-show-message-top ()
728   (car (notmuch-show-message-extent)))
729
730 (defun notmuch-show-message-bottom ()
731   (cdr (notmuch-show-message-extent)))
732
733 (defun notmuch-show-goto-message-next ()
734   (let ((start (point)))
735     (notmuch-show-move-to-message-bottom)
736     (if (not (eobp))
737         t
738       (goto-char start)
739       nil)))
740
741 (defun notmuch-show-goto-message-previous ()
742   (notmuch-show-move-to-message-top)
743   (if (bobp)
744       nil
745     (backward-char)
746     (notmuch-show-move-to-message-top)
747     t))
748
749 (defun notmuch-show-move-past-invisible-forward ()
750   (while (point-invisible-p)
751     (forward-char)))
752
753 (defun notmuch-show-move-past-invisible-backward ()
754   (while (point-invisible-p)
755     (backward-char)))
756
757 ;; Functions relating to the visibility of messages and their
758 ;; components.
759
760 (defun notmuch-show-element-visible (props visible-p spec-property)
761   (let ((spec (plist-get props spec-property)))
762     (if visible-p
763         (remove-from-invisibility-spec spec)
764       (add-to-invisibility-spec spec))))
765
766 (defun notmuch-show-message-visible (props visible-p)
767   (if visible-p
768       ;; When making the message visible, the headers may or not be
769       ;; visible. So we check that property separately.
770       (let ((headers-visible (plist-get props :headers-visible)))
771         (notmuch-show-element-visible props headers-visible :headers-invis-spec)
772         (notmuch-show-element-visible props t :message-invis-spec))
773     (notmuch-show-element-visible props nil :headers-invis-spec)
774     (notmuch-show-element-visible props nil :message-invis-spec))
775
776   (notmuch-show-set-prop :message-visible visible-p props))
777
778 (defun notmuch-show-headers-visible (props visible-p)
779   (if (plist-get props :message-visible)
780       (notmuch-show-element-visible props visible-p :headers-invis-spec))
781   (notmuch-show-set-prop :headers-visible visible-p props))
782
783 ;; Functions for setting and getting attributes of the current
784 ;; message.
785
786 (defun notmuch-show-set-message-properties (props)
787   (save-excursion
788     (notmuch-show-move-to-message-top)
789     (put-text-property (point) (+ (point) 1) :notmuch-message-properties props)))
790
791 (defun notmuch-show-get-message-properties ()
792   (save-excursion
793     (notmuch-show-move-to-message-top)
794     (get-text-property (point) :notmuch-message-properties)))
795
796 (defun notmuch-show-set-prop (prop val &optional props)
797   (let ((inhibit-read-only t)
798         (props (or props
799                    (notmuch-show-get-message-properties))))
800     (plist-put props prop val)
801     (notmuch-show-set-message-properties props)))
802
803 (defun notmuch-show-get-prop (prop &optional props)
804   (let ((props (or props
805                    (notmuch-show-get-message-properties))))
806     (plist-get props prop)))
807
808 (defun notmuch-show-get-message-id ()
809   "Return the message id of the current message."
810   (concat "id:\"" (notmuch-show-get-prop :id) "\""))
811
812 ;; dme: Would it make sense to use a macro for many of these?
813
814 (defun notmuch-show-get-filename ()
815   "Return the filename of the current message."
816   (notmuch-show-get-prop :filename))
817
818 (defun notmuch-show-get-header (header)
819   "Return the named header of the current message, if any."
820   (plist-get (notmuch-show-get-prop :headers) header))
821
822 (defun notmuch-show-get-cc ()
823   (notmuch-show-get-header :Cc))
824
825 (defun notmuch-show-get-date ()
826   (notmuch-show-get-header :Date))
827
828 (defun notmuch-show-get-from ()
829   (notmuch-show-get-header :From))
830
831 (defun notmuch-show-get-subject ()
832   (notmuch-show-get-header :Subject))
833
834 (defun notmuch-show-get-to ()
835   (notmuch-show-get-header :To))
836
837 (defun notmuch-show-set-tags (tags)
838   "Set the tags of the current message."
839   (notmuch-show-set-prop :tags tags)
840   (notmuch-show-update-tags tags))
841
842 (defun notmuch-show-get-tags ()
843   "Return the tags of the current message."
844   (notmuch-show-get-prop :tags))
845
846 (defun notmuch-show-message-visible-p ()
847   "Is the current message visible?"
848   (notmuch-show-get-prop :message-visible))
849
850 (defun notmuch-show-headers-visible-p ()
851   "Are the headers of the current message visible?"
852   (notmuch-show-get-prop :headers-visible))
853
854 (defun notmuch-show-mark-read ()
855   "Mark the current message as read."
856   (notmuch-show-remove-tag "unread"))
857
858 ;; Functions for getting attributes of several messages in the current
859 ;; thread.
860
861 (defun notmuch-show-get-message-ids-for-open-messages ()
862   "Return a list of all message IDs for open messages in the current thread."
863   (save-excursion
864     (let (message-ids done)
865       (goto-char (point-min))
866       (while (not done)
867         (if (notmuch-show-message-visible-p)
868             (setq message-ids (append message-ids (list (notmuch-show-get-message-id)))))
869         (setq done (not (notmuch-show-goto-message-next)))
870         )
871       message-ids
872       )))
873
874 ;; Commands typically bound to keys.
875
876 (defun notmuch-show-advance-and-archive ()
877   "Advance through thread and archive.
878
879 This command is intended to be one of the simplest ways to
880 process a thread of email. It does the following:
881
882 If the current message in the thread is not yet fully visible,
883 scroll by a near screenful to read more of the message.
884
885 Otherwise, (the end of the current message is already within the
886 current window), advance to the next open message.
887
888 Finally, if there is no further message to advance to, and this
889 last message is already read, then archive the entire current
890 thread, (remove the \"inbox\" tag from each message). Also kill
891 this buffer, and display the next thread from the search from
892 which this thread was originally shown."
893   (interactive)
894   (let ((end-of-this-message (notmuch-show-message-bottom)))
895     (cond
896      ;; Ideally we would test `end-of-this-message' against the result
897      ;; of `window-end', but that doesn't account for the fact that
898      ;; the end of the message might be hidden, so we have to actually
899      ;; go to the end, walk back over invisible text and then see if
900      ;; point is visible.
901      ((save-excursion
902         (goto-char (- end-of-this-message 1))
903         (notmuch-show-move-past-invisible-backward)
904         (> (point) (window-end)))
905       ;; The bottom of this message is not visible - scroll.
906       (scroll-up nil))
907
908      ((not (= end-of-this-message (point-max)))
909       ;; This is not the last message - move to the next visible one.
910       (notmuch-show-next-open-message))
911
912      (t
913       ;; This is the last message - archive the thread.
914       (notmuch-show-archive-thread)))))
915
916 (defun notmuch-show-rewind ()
917   "Backup through the thread, (reverse scrolling compared to \\[notmuch-show-advance-and-archive]).
918
919 Specifically, if the beginning of the previous email is fewer
920 than `window-height' lines from the current point, move to it
921 just like `notmuch-show-previous-message'.
922
923 Otherwise, just scroll down a screenful of the current message.
924
925 This command does not modify any message tags, (it does not undo
926 any effects from previous calls to
927 `notmuch-show-advance-and-archive'."
928   (interactive)
929   (let ((start-of-message (notmuch-show-message-top))
930         (start-of-window (window-start)))
931     (cond
932       ;; Either this message is properly aligned with the start of the
933       ;; window or the start of this message is not visible on the
934       ;; screen - scroll.
935      ((or (= start-of-message start-of-window)
936           (< start-of-message start-of-window))
937       (scroll-down)
938       ;; If a small number of lines from the previous message are
939       ;; visible, realign so that the top of the current message is at
940       ;; the top of the screen.
941       (if (<= (count-screen-lines (window-start) start-of-message)
942               next-screen-context-lines)
943           (progn
944             (goto-char (notmuch-show-message-top))
945             (notmuch-show-message-adjust)))
946       ;; Move to the top left of the window.
947       (goto-char (window-start)))
948      (t
949       ;; Move to the previous message.
950       (notmuch-show-previous-message)))))
951
952 (defun notmuch-show-reply ()
953   "Reply to the current message."
954   (interactive)
955   (notmuch-mua-reply (notmuch-show-get-message-id)))
956
957 (defun notmuch-show-forward-message ()
958   "Forward the current message."
959   (interactive)
960   (with-current-notmuch-show-message
961    (notmuch-mua-forward-message)))
962
963 (defun notmuch-show-next-message ()
964   "Show the next message."
965   (interactive)
966   (if (notmuch-show-goto-message-next)
967       (progn
968         (notmuch-show-mark-read)
969         (notmuch-show-message-adjust))
970     (goto-char (point-max))))
971
972 (defun notmuch-show-previous-message ()
973   "Show the previous message."
974   (interactive)
975   (notmuch-show-goto-message-previous)
976   (notmuch-show-mark-read)
977   (notmuch-show-message-adjust))
978
979 (defun notmuch-show-next-open-message ()
980   "Show the next message."
981   (interactive)
982   (let (r)
983     (while (and (setq r (notmuch-show-goto-message-next))
984                 (not (notmuch-show-message-visible-p))))
985     (if r
986         (progn
987           (notmuch-show-mark-read)
988           (notmuch-show-message-adjust))
989       (goto-char (point-max)))))
990
991 (defun notmuch-show-previous-open-message ()
992   "Show the previous message."
993   (interactive)
994   (while (and (notmuch-show-goto-message-previous)
995               (not (notmuch-show-message-visible-p))))
996   (notmuch-show-mark-read)
997   (notmuch-show-message-adjust))
998
999 (defun notmuch-show-view-raw-message ()
1000   "View the file holding the current message."
1001   (interactive)
1002   (let* ((id (notmuch-show-get-message-id))
1003          (buf (get-buffer-create (concat "*notmuch-raw-" id "*"))))
1004     (call-process notmuch-command nil buf nil "show" "--format=raw" id)
1005     (switch-to-buffer buf)
1006     (goto-char (point-min))
1007     (set-buffer-modified-p nil)
1008     (view-buffer buf 'kill-buffer-if-not-modified)))
1009
1010 (defun notmuch-show-pipe-message (entire-thread command)
1011   "Pipe the contents of the current message (or thread) to the given command.
1012
1013 The given command will be executed with the raw contents of the
1014 current email message as stdin. Anything printed by the command
1015 to stdout or stderr will appear in the *notmuch-pipe* buffer.
1016
1017 When invoked with a prefix argument, the command will receive all
1018 open messages in the current thread (formatted as an mbox) rather
1019 than only the current message."
1020   (interactive "P\nsPipe message to command: ")
1021   (let (shell-command)
1022     (if entire-thread
1023         (setq shell-command 
1024               (concat notmuch-command " show --format=mbox "
1025                       (shell-quote-argument
1026                        (mapconcat 'identity (notmuch-show-get-message-ids-for-open-messages) " OR "))
1027                       " | " command))
1028       (setq shell-command
1029             (concat notmuch-command " show --format=raw "
1030                     (shell-quote-argument (notmuch-show-get-message-id)) " | " command)))
1031     (let ((buf (get-buffer-create (concat "*notmuch-pipe*"))))
1032       (with-current-buffer buf
1033         (setq buffer-read-only nil)
1034         (erase-buffer)
1035         (let ((exit-code (call-process-shell-command shell-command nil buf)))
1036           (goto-char (point-max))
1037           (set-buffer-modified-p nil)
1038           (setq buffer-read-only t)
1039           (unless (zerop exit-code)
1040             (switch-to-buffer-other-window buf)
1041             (message (format "Command '%s' exited abnormally with code %d"
1042                              shell-command exit-code))))))))
1043
1044 (defun notmuch-show-add-tags-worker (current-tags add-tags)
1045   "Add to `current-tags' with any tags from `add-tags' not
1046 currently present and return the result."
1047   (let ((result-tags (copy-sequence current-tags)))
1048     (mapc (lambda (add-tag)
1049             (unless (member add-tag current-tags)
1050               (setq result-tags (push add-tag result-tags))))
1051             add-tags)
1052     (sort result-tags 'string<)))
1053
1054 (defun notmuch-show-del-tags-worker (current-tags del-tags)
1055   "Remove any tags in `del-tags' from `current-tags' and return
1056 the result."
1057   (let ((result-tags (copy-sequence current-tags)))
1058     (mapc (lambda (del-tag)
1059             (setq result-tags (delete del-tag result-tags)))
1060           del-tags)
1061     result-tags))
1062
1063 (defun notmuch-show-add-tag (&rest toadd)
1064   "Add a tag to the current message."
1065   (interactive
1066    (list (notmuch-select-tag-with-completion "Tag to add: ")))
1067
1068   (let* ((current-tags (notmuch-show-get-tags))
1069          (new-tags (notmuch-show-add-tags-worker current-tags toadd)))
1070
1071     (unless (equal current-tags new-tags)
1072       (apply 'notmuch-call-notmuch-process
1073              (append (cons "tag"
1074                            (mapcar (lambda (s) (concat "+" s)) toadd))
1075                      (cons (notmuch-show-get-message-id) nil)))
1076       (notmuch-show-set-tags new-tags))))
1077
1078 (defun notmuch-show-remove-tag (&rest toremove)
1079   "Remove a tag from the current message."
1080   (interactive
1081    (list (notmuch-select-tag-with-completion
1082           "Tag to remove: " (notmuch-show-get-message-id))))
1083
1084   (let* ((current-tags (notmuch-show-get-tags))
1085          (new-tags (notmuch-show-del-tags-worker current-tags toremove)))
1086
1087     (unless (equal current-tags new-tags)
1088       (apply 'notmuch-call-notmuch-process
1089              (append (cons "tag"
1090                            (mapcar (lambda (s) (concat "-" s)) toremove))
1091                      (cons (notmuch-show-get-message-id) nil)))
1092       (notmuch-show-set-tags new-tags))))
1093
1094 (defun notmuch-show-toggle-headers ()
1095   "Toggle the visibility of the current message headers."
1096   (interactive)
1097   (let ((props (notmuch-show-get-message-properties)))
1098     (notmuch-show-headers-visible
1099      props
1100      (not (plist-get props :headers-visible))))
1101   (force-window-update))
1102
1103 (defun notmuch-show-toggle-message ()
1104   "Toggle the visibility of the current message."
1105   (interactive)
1106   (let ((props (notmuch-show-get-message-properties)))
1107     (notmuch-show-message-visible
1108      props
1109      (not (plist-get props :message-visible))))
1110   (force-window-update))
1111
1112 (defun notmuch-show-open-or-close-all ()
1113   "Set the visibility all of the messages in the current thread.
1114 By default make all of the messages visible. With a prefix
1115 argument, hide all of the messages."
1116   (interactive)
1117   (save-excursion
1118     (goto-char (point-min))
1119     (loop do (notmuch-show-message-visible (notmuch-show-get-message-properties)
1120                                            (not current-prefix-arg))
1121           until (not (notmuch-show-goto-message-next))))
1122   (force-window-update))
1123
1124 (defun notmuch-show-next-button ()
1125   "Advance point to the next button in the buffer."
1126   (interactive)
1127   (forward-button 1))
1128
1129 (defun notmuch-show-previous-button ()
1130   "Move point back to the previous button in the buffer."
1131   (interactive)
1132   (backward-button 1))
1133
1134 (defun notmuch-show-archive-thread-internal (show-next)
1135   ;; Remove the tag from the current set of messages.
1136   (goto-char (point-min))
1137   (loop do (notmuch-show-remove-tag "inbox")
1138         until (not (notmuch-show-goto-message-next)))
1139   ;; Move to the next item in the search results, if any.
1140   (let ((parent-buffer notmuch-show-parent-buffer))
1141     (notmuch-kill-this-buffer)
1142     (if parent-buffer
1143         (progn
1144           (switch-to-buffer parent-buffer)
1145           (forward-line)
1146           (if show-next
1147               (notmuch-search-show-thread))))))
1148
1149 (defun notmuch-show-archive-thread ()
1150   "Archive each message in thread, then show next thread from search.
1151
1152 Archive each message currently shown by removing the \"inbox\"
1153 tag from each. Then kill this buffer and show the next thread
1154 from the search from which this thread was originally shown.
1155
1156 Note: This command is safe from any race condition of new messages
1157 being delivered to the same thread. It does not archive the
1158 entire thread, but only the messages shown in the current
1159 buffer."
1160   (interactive)
1161   (notmuch-show-archive-thread-internal t))
1162
1163 (defun notmuch-show-archive-thread-then-exit ()
1164   "Archive each message in thread, then exit back to search results."
1165   (interactive)
1166   (notmuch-show-archive-thread-internal nil))
1167
1168 (defun notmuch-show-stash-cc ()
1169   "Copy CC field of current message to kill-ring."
1170   (interactive)
1171   (notmuch-common-do-stash (notmuch-show-get-cc)))
1172
1173 (defun notmuch-show-stash-date ()
1174   "Copy date of current message to kill-ring."
1175   (interactive)
1176   (notmuch-common-do-stash (notmuch-show-get-date)))
1177
1178 (defun notmuch-show-stash-filename ()
1179   "Copy filename of current message to kill-ring."
1180   (interactive)
1181   (notmuch-common-do-stash (notmuch-show-get-filename)))
1182
1183 (defun notmuch-show-stash-from ()
1184   "Copy From address of current message to kill-ring."
1185   (interactive)
1186   (notmuch-common-do-stash (notmuch-show-get-from)))
1187
1188 (defun notmuch-show-stash-message-id ()
1189   "Copy message ID of current message to kill-ring."
1190   (interactive)
1191   (notmuch-common-do-stash (notmuch-show-get-message-id)))
1192
1193 (defun notmuch-show-stash-subject ()
1194   "Copy Subject field of current message to kill-ring."
1195   (interactive)
1196   (notmuch-common-do-stash (notmuch-show-get-subject)))
1197
1198 (defun notmuch-show-stash-tags ()
1199   "Copy tags of current message to kill-ring as a comma separated list."
1200   (interactive)
1201   (notmuch-common-do-stash (mapconcat 'identity (notmuch-show-get-tags) ",")))
1202
1203 (defun notmuch-show-stash-to ()
1204   "Copy To address of current message to kill-ring."
1205   (interactive)
1206   (notmuch-common-do-stash (notmuch-show-get-to)))
1207
1208 ;; Commands typically bound to buttons.
1209
1210 (defun notmuch-show-part-button-action (button)
1211   (let ((nth (button-get button :notmuch-part)))
1212     (if nth
1213         (notmuch-show-save-part (notmuch-show-get-message-id) nth
1214                                 (button-get button :notmuch-filename))
1215       (message "Not a valid part (is it a fake part?)."))))
1216
1217 ;;
1218
1219 (provide 'notmuch-show)