X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-mua.el;h=1efc88ea4020ceaef8b667e0d68c81a472b478dd;hp=ad84c8a02a554bb78e22320bb64bab94b677c111;hb=ed40579ad3882e6f9bbe9b1ba5e707ab289ca203;hpb=967bbc0792d8d36cdf1e110d8b9eb0aa26d8a646 diff --git a/emacs/notmuch-mua.el b/emacs/notmuch-mua.el index ad84c8a0..1efc88ea 100644 --- a/emacs/notmuch-mua.el +++ b/emacs/notmuch-mua.el @@ -21,19 +21,22 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (require 'message) (require 'mm-view) (require 'format-spec) (require 'notmuch-lib) (require 'notmuch-address) - -(eval-when-compile (require 'cl)) +(require 'notmuch-draft) +(require 'notmuch-message) (declare-function notmuch-show-insert-body "notmuch-show" (msg body depth)) (declare-function notmuch-fcc-header-setup "notmuch-maildir-fcc" ()) -(declare-function notmuch-fcc-handler "notmuch-maildir-fcc" (destdir)) (declare-function notmuch-maildir-message-do-fcc "notmuch-maildir-fcc" ()) +(declare-function notmuch-draft-postpone "notmuch-draft" ()) +(declare-function notmuch-draft-save "notmuch-draft" ()) ;; @@ -101,7 +104,7 @@ Note that these functions use `mail-citation-hook' if that is non-nil." "Function to decide which parts get a header when replying. This function specifies which parts of a mime message with -mutiple parts get a header." +multiple parts get a header." :type '(radio (const :tag "No part headers" notmuch-show-reply-insert-header-p-never) (const :tag "All except multipart/* and hidden parts" @@ -113,8 +116,51 @@ mutiple parts get a header." (function :tag "Other")) :group 'notmuch-reply) +(defcustom notmuch-mua-attachment-regexp + "\\b\\(attache\?ment\\|attached\\|attach\\|pi[èe]ce\s+jointe?\\)\\b" + "Message body text indicating that an attachment is expected. + +This is not used unless `notmuch-mua-attachment-check' is added +to `notmuch-mua-send-hook'." + :type 'regexp + :group 'notmuch-send) + ;; +(defun notmuch-mua-attachment-check () + "Signal an error if the message text indicates that an +attachment is expected but no MML referencing an attachment is +found. + +Typically this is added to `notmuch-mua-send-hook'." + (when (and + ;; When the message mentions attachment... + (save-excursion + (message-goto-body) + ;; Limit search from reaching other possible parts of the message + (let ((search-limit (search-forward "\n<#" nil t))) + (message-goto-body) + (cl-loop while (re-search-forward notmuch-mua-attachment-regexp + search-limit t) + ;; For every instance of the "attachment" string + ;; found, examine the text properties. If the text + ;; has either a `face' or `syntax-table' property + ;; then it is quoted text and should *not* cause the + ;; user to be asked about a missing attachment. + if (let ((props (text-properties-at (match-beginning 0)))) + (not (or (memq 'syntax-table props) + (memq 'face props)))) + return t + finally return nil))) + ;; ...but doesn't have a part with a filename... + (save-excursion + (message-goto-body) + (not (re-search-forward "^<#part [^>]*filename=" nil t))) + ;; ...and that's not okay... + (not (y-or-n-p "Attachment mentioned, but no attachment - is that okay?"))) + ;; ...signal an error. + (error "Missing attachment"))) + (defun notmuch-mua-get-switch-function () "Get a switch function according to `notmuch-mua-compose-in'." (cond ((eq notmuch-mua-compose-in 'current-window) @@ -158,11 +204,11 @@ mutiple parts get a header." (defun notmuch-mua-reply-crypto (parts) "Add mml sign-encrypt flag if any part of original message is encrypted." - (loop for part in parts - if (notmuch-match-content-type (plist-get part :content-type) "multipart/encrypted") - do (mml-secure-message-sign-encrypt) - else if (notmuch-match-content-type (plist-get part :content-type) "multipart/*") - do (notmuch-mua-reply-crypto (plist-get part :content)))) + (cl-loop for part in parts + if (notmuch-match-content-type (plist-get part :content-type) "multipart/encrypted") + do (mml-secure-message-sign-encrypt) + else if (notmuch-match-content-type (plist-get part :content-type) "multipart/*") + do (notmuch-mua-reply-crypto (plist-get part :content)))) ;; There is a bug in emacs 23's message.el that results in a newline ;; not being inserted after the References header, so the next header @@ -174,12 +220,12 @@ mutiple parts get a header." (unless (bolp) (insert "\n"))) (defun notmuch-mua-reply (query-string &optional sender reply-all) - (let ((args '("reply" "--format=sexp" "--format-version=1")) + (let ((args '("reply" "--format=sexp" "--format-version=4")) (process-crypto notmuch-show-process-crypto) reply original) (when process-crypto - (setq args (append args '("--decrypt")))) + (setq args (append args '("--decrypt=true")))) (if reply-all (setq args (append args '("--reply-to=all"))) @@ -207,19 +253,24 @@ mutiple parts get a header." ;; We modify message-header-format-alist to get around a bug in message.el. ;; See the comment above on notmuch-mua-insert-references. (let ((message-header-format-alist - (loop for pair in message-header-format-alist - if (eq (car pair) 'References) - collect (cons 'References - (apply-partially - 'notmuch-mua-insert-references - (cdr pair))) - else - collect pair))) + (cl-loop for pair in message-header-format-alist + if (eq (car pair) 'References) + collect (cons 'References + (apply-partially + 'notmuch-mua-insert-references + (cdr pair))) + else + collect pair))) (notmuch-mua-mail (plist-get reply-headers :To) - (plist-get reply-headers :Subject) + (notmuch-sanitize (plist-get reply-headers :Subject)) (notmuch-headers-plist-to-alist reply-headers) nil (notmuch-mua-get-switch-function)))) + ;; Create a buffer-local queue for tag changes triggered when sending the reply + (when notmuch-message-replied-tags + (setq-local notmuch-message-queued-tag-changes + (list (cons query-string notmuch-message-replied-tags)))) + ;; Insert the message body - but put it in front of the signature ;; if one is present, and after any other content ;; message*setup-hooks may have added to the message body already. @@ -252,10 +303,17 @@ mutiple parts get a header." (notmuch-show-max-text-part-size 0) ;; Insert headers for parts as appropriate for replying. (notmuch-show-insert-header-p-function notmuch-mua-reply-insert-header-p-function) + ;; Ensure that any encrypted parts are + ;; decrypted during the generation of the reply + ;; text. + (notmuch-show-process-crypto process-crypto) ;; Don't indent multipart sub-parts. (notmuch-show-indent-multipart nil)) - (notmuch-show-insert-body original (plist-get original :body) 0) - (buffer-substring-no-properties (point-min) (point-max))))) + ;; We don't want sigstatus buttons (an information leak and usually wrong anyway). + (cl-letf (((symbol-function 'notmuch-crypto-insert-sigstatus-button) #'ignore) + ((symbol-function 'notmuch-crypto-insert-encstatus-button) #'ignore)) + (notmuch-show-insert-body original (plist-get original :body) 0) + (buffer-substring-no-properties (point-min) (point-max)))))) (set-mark (point)) (goto-char start) @@ -276,13 +334,15 @@ mutiple parts get a header." (set-buffer-modified-p nil)) (define-derived-mode notmuch-message-mode message-mode "Message[Notmuch]" - "Notmuch message composition mode. Mostly like `message-mode'" + "Notmuch message composition mode. Mostly like `message-mode'." (notmuch-address-setup)) (put 'notmuch-message-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify) (define-key notmuch-message-mode-map (kbd "C-c C-c") #'notmuch-mua-send-and-exit) (define-key notmuch-message-mode-map (kbd "C-c C-s") #'notmuch-mua-send) +(define-key notmuch-message-mode-map (kbd "C-c C-p") #'notmuch-draft-postpone) +(define-key notmuch-message-mode-map (kbd "C-x C-s") #'notmuch-draft-save) (defun notmuch-mua-pop-to-buffer (name switch-function) "Pop to buffer NAME, and warn if it already exists and is @@ -295,7 +355,7 @@ modified. This function is notmuch addaptation of (if window ;; Raise the frame already displaying the message buffer. (progn - (gnus-select-frame-set-input-focus (window-frame window)) + (select-frame-set-input-focus (window-frame window)) (select-window window)) (funcall switch-function buffer) (set-buffer buffer)) @@ -422,8 +482,10 @@ the From: address." (let* ((other-headers (when (or prompt-for-sender notmuch-always-prompt-for-sender) (list (cons 'From (notmuch-mua-prompt-for-sender))))) - forward-subject) ;; Comes from the first message and is + forward-subject ;; Comes from the first message and is ;; applied later. + forward-references ;; List of accumulated message-references of forwarded messages + forward-queries) ;; List of corresponding message-query ;; Generate the template for the outgoing message. (notmuch-mua-mail nil "" other-headers nil (notmuch-mua-get-switch-function)) @@ -441,7 +503,9 @@ the From: address." ;; Because we process the messages in reverse order, ;; always generate a forwarded subject, then use the ;; last (i.e. first) one. - (setq forward-subject (message-make-forward-subject))) + (setq forward-subject (message-make-forward-subject)) + (push (message-fetch-field "Message-ID") forward-references) + (push id forward-queries)) ;; Make a copy ready to be forwarded in the ;; composition buffer. (message-forward-make-body temp-buffer) @@ -455,7 +519,17 @@ the From: address." (save-restriction (message-narrow-to-headers) (message-remove-header "Subject") - (message-add-header (concat "Subject: " forward-subject))) + (message-add-header (concat "Subject: " forward-subject)) + (message-remove-header "References") + (message-add-header (concat "References: " + (mapconcat 'identity forward-references " ")))) + + ;; Create a buffer-local queue for tag changes triggered when sending the message + (when notmuch-message-forwarded-tags + (setq-local notmuch-message-queued-tag-changes + (cl-loop for id in forward-queries + collect + (cons id notmuch-message-forwarded-tags)))) ;; `message-forward-make-body' shows the User-agent header. Hide ;; it again. @@ -488,17 +562,65 @@ will be addressed to all recipients of the source message." (notmuch-mua-reply query-string sender reply-all) (deactivate-mark))) +(defun notmuch-mua-check-no-misplaced-secure-tag () + "Query user if there is a misplaced secure mml tag. + +Emacs message-send will (probably) ignore a secure mml tag unless +it is at the start of the body. Returns t if there is no such +tag, or the user confirms they mean it." + (save-excursion + (let ((body-start (progn (message-goto-body) (point)))) + (goto-char (point-max)) + (or + ;; We are always fine if there is no secure tag. + (not (search-backward "<#secure" nil 't)) + ;; There is a secure tag, so it must be at the start of the + ;; body, with no secure tag earlier (i.e., in the headers). + (and (= (point) body-start) + (not (search-backward "<#secure" nil 't))) + ;; The user confirms they means it. + (yes-or-no-p "\ +There is a <#secure> tag not at the start of the body. It is +likely that the message will be sent unsigned and unencrypted. +Really send? "))))) + +(defun notmuch-mua-check-secure-tag-has-newline () + "Query if the secure mml tag has a newline following it. + +Emacs message-send will (probably) ignore a correctly placed +secure mml tag unless it is followed by a newline. Returns t if +any secure tag is followed by a newline, or the user confirms +they mean it." + (save-excursion + (message-goto-body) + (or + ;; There is no (correctly placed) secure tag. + (not (looking-at "<#secure")) + ;; The secure tag is followed by a newline. + (looking-at "<#secure[^\n>]*>\n") + ;; The user confirms they means it. + (yes-or-no-p "\ +The <#secure> tag at the start of the body is not followed by a +newline. It is likely that the message will be sent unsigned and +unencrypted. Really send? ")))) + +(defun notmuch-mua-send-common (arg &optional exit) + (interactive "P") + (run-hooks 'notmuch-mua-send-hook) + (when (and (notmuch-mua-check-no-misplaced-secure-tag) + (notmuch-mua-check-secure-tag-has-newline)) + (cl-letf (((symbol-function 'message-do-fcc) #'notmuch-maildir-message-do-fcc)) + (if exit + (message-send-and-exit arg) + (message-send arg))))) + (defun notmuch-mua-send-and-exit (&optional arg) (interactive "P") - (let ((message-fcc-handler-function #'notmuch-fcc-handler)) - (letf (((symbol-function 'message-do-fcc) #'notmuch-maildir-message-do-fcc)) - (message-send-and-exit arg)))) + (notmuch-mua-send-common arg 't)) (defun notmuch-mua-send (&optional arg) (interactive "P") - (let ((message-fcc-handler-function #'notmuch-fcc-handler)) - (letf (((symbol-function 'message-do-fcc) #'notmuch-maildir-message-do-fcc)) - (message-send arg)))) + (notmuch-mua-send-common arg)) (defun notmuch-mua-kill-buffer () (interactive)