git.notmuchmail.org Git - notmuch/blob - emacs/notmuch-maildir-fcc.el

   1 ;;; notmuch-maildir-fcc.el --- inserting using a fcc handler  -*- lexical-binding: t -*-
   2
   3 ;; Copyright © Jesse Rosenthal
   4 ;;
   5 ;; This file is part of Notmuch.
   6 ;;
   7 ;; Notmuch is free software: you can redistribute it and/or modify it
   8 ;; under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11 ;;
  12 ;; Notmuch is distributed in the hope that it will be useful, but
  13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;; General Public License for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with Notmuch.  If not, see <https://www.gnu.org/licenses/>.
  19 ;;
  20 ;; Authors: Jesse Rosenthal <jrosenthal@jhu.edu>
  21
  22 ;;; Code:
  23
  24 (eval-when-compile (require 'cl-lib))
  25
  26 (require 'message)
  27
  28 (require 'notmuch-lib)
  29
  30 (defvar notmuch-maildir-fcc-count 0)
  31
  32 ;;; Options
  33
  34 (defcustom notmuch-fcc-dirs "sent"
  35   "Determines the Fcc Header which says where to save outgoing mail.
  36
  37 Three types of values are permitted:
  38
  39 - nil: no Fcc header is added,
  40
  41 - a string: the value of `notmuch-fcc-dirs' is the Fcc header to
  42   be used.
  43
  44 - a list: the folder is chosen based on the From address of the
  45   current message using a list of regular expressions and
  46   corresponding folders:
  47
  48      ((\"Sebastian@SSpaeth.de\" . \"privat\")
  49       (\"spaetz@sspaeth.de\" . \"OUTBOX.OSS\")
  50       (\".*\" . \"defaultinbox\"))
  51
  52   If none of the regular expressions match the From address, no
  53   Fcc header will be added.
  54
  55 If `notmuch-maildir-use-notmuch-insert' is set (the default) then
  56 the header should be of the form \"folder +tag1 -tag2\" where
  57 folder is the folder (relative to the notmuch mailstore) to store
  58 the message in, and tag1 and tag2 are tag changes to apply to the
  59 stored message. This string is split using `split-string-and-unquote',
  60 so a folder name containing spaces can be specified by
  61 quoting each space with an immediately preceding backslash
  62 or surrounding the entire folder name in double quotes.
  63
  64 If `notmuch-maildir-use-notmuch-insert' is nil then the Fcc
  65 header should be the directory where the message should be
  66 saved. A relative directory will be understood to specify a
  67 directory within the notmuch mail store, (as set by the
  68 database.path option in the notmuch configuration file).
  69
  70 In all cases you will be prompted to create the folder or
  71 directory if it does not exist yet when sending a mail."
  72
  73   :type '(choice
  74           (const :tag "No FCC header" nil)
  75           (string :tag "A single folder")
  76           (repeat :tag "A folder based on the From header"
  77                   (cons regexp (string :tag "Folder"))))
  78   :require 'notmuch-fcc-initialization
  79   :group 'notmuch-send)
  80
  81 (defcustom notmuch-maildir-use-notmuch-insert t
  82   "Should fcc use notmuch insert instead of simple fcc."
  83   :type '(choice :tag "Fcc Method"
  84                  (const :tag "Use notmuch insert" t)
  85                  (const :tag "Use simple fcc" nil))
  86   :group 'notmuch-send)
  87
  88 ;;; Functions which set up the fcc header in the message buffer.
  89
  90 (defun notmuch-fcc-header-setup ()
  91   "Add an Fcc header to the current message buffer.
  92
  93 Sets the Fcc header based on the values of `notmuch-fcc-dirs'.
  94
  95 Originally intended to be use a hook function, but now called directly
  96 by notmuch-mua-mail."
  97   (let ((subdir
  98          (cond
  99           ((or (not notmuch-fcc-dirs)
 100                (message-field-value "Fcc"))
 101            ;; Nothing set or an existing header.
 102            nil)
 103           ((stringp notmuch-fcc-dirs)
 104            notmuch-fcc-dirs)
 105           ((and (listp notmuch-fcc-dirs)
 106                 (stringp (car notmuch-fcc-dirs)))
 107            ;; Old style - no longer works.
 108            (error "Invalid `notmuch-fcc-dirs' setting (old style)"))
 109           ((listp notmuch-fcc-dirs)
 110            (or (seq-some (let ((from (message-field-value "From")))
 111                            (pcase-lambda (`(,regexp . ,folder))
 112                              (and (string-match-p regexp from)
 113                                   folder)))
 114                          notmuch-fcc-dirs)
 115                (progn (message "No Fcc header added.")
 116                       nil)))
 117           (t
 118            (error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)")))))
 119     (when subdir
 120       (if notmuch-maildir-use-notmuch-insert
 121           (notmuch-maildir-add-notmuch-insert-style-fcc-header subdir)
 122         (notmuch-maildir-add-file-style-fcc-header subdir)))))
 123
 124 (defun notmuch-maildir-add-notmuch-insert-style-fcc-header (subdir)
 125   ;; Notmuch insert does not accept absolute paths, so check the user
 126   ;; really want this header inserted.
 127   (when (or (not (= (elt subdir 0) ?/))
 128             (y-or-n-p (format "Fcc header %s is an absolute path %s %s" subdir
 129                               "and notmuch insert is requested."
 130                               "Insert header anyway? ")))
 131     (message-add-header (concat "Fcc: " subdir))))
 132
 133 (defun notmuch-maildir-add-file-style-fcc-header (subdir)
 134   (message-add-header
 135    (concat "Fcc: "
 136            (file-truename
 137             ;; If the resulting directory is not an absolute path,
 138             ;; prepend the standard notmuch database path.
 139             (if (= (elt subdir 0) ?/)
 140                 subdir
 141               (concat (notmuch-database-path) "/" subdir))))))
 142
 143 ;;; Functions for saving a message using either method.
 144
 145 (defmacro with-temporary-notmuch-message-buffer (&rest body)
 146   "Set-up a temporary copy of the current message-mode buffer."
 147   `(let ((case-fold-search t)
 148          (buf (current-buffer))
 149          (mml-externalize-attachments message-fcc-externalize-attachments))
 150      (with-current-buffer (get-buffer-create " *message temp*")
 151        (erase-buffer)
 152        (insert-buffer-substring buf)
 153        ,@body)))
 154
 155 (defun notmuch-maildir-setup-message-for-saving ()
 156   "Setup message for saving. Should be called on a temporary copy.
 157
 158 This is taken from the function message-do-fcc."
 159   (message-encode-message-body)
 160   (save-restriction
 161     (message-narrow-to-headers)
 162     (mail-encode-encoded-word-buffer))
 163   (goto-char (point-min))
 164   (when (re-search-forward
 165          (concat "^" (regexp-quote mail-header-separator) "$")
 166          nil t)
 167     (replace-match "" t t )))
 168
 169 (defun notmuch-maildir-message-do-fcc ()
 170   "Process Fcc headers in the current buffer.
 171
 172 This is a rearranged version of message mode's message-do-fcc."
 173   (let (files file)
 174     (save-excursion
 175       (save-restriction
 176         (message-narrow-to-headers)
 177         (setq file (message-fetch-field "fcc" t)))
 178       (when file
 179         (with-temporary-notmuch-message-buffer
 180          (save-restriction
 181            (message-narrow-to-headers)
 182            (while (setq file (message-fetch-field "fcc" t))
 183              (push file files)
 184              (message-remove-header "fcc" nil t)))
 185          (notmuch-maildir-setup-message-for-saving)
 186          ;; Process FCC operations.
 187          (mapc #'notmuch-fcc-handler files)
 188          (kill-buffer (current-buffer)))))))
 189
 190 (defun notmuch-fcc-handler (fcc-header)
 191   "Store message with notmuch insert or normal (file) fcc.
 192
 193 If `notmuch-maildir-use-notmuch-insert' is set then store the
 194 message using notmuch insert. Otherwise store the message using
 195 normal fcc."
 196   (message "Doing Fcc...")
 197   (if notmuch-maildir-use-notmuch-insert
 198       (notmuch-maildir-fcc-with-notmuch-insert fcc-header)
 199     (notmuch-maildir-fcc-file-fcc fcc-header))
 200   (message "Doing Fcc...done"))
 201
 202 ;;; Functions for saving a message using notmuch insert.
 203
 204 (defun notmuch-maildir-notmuch-insert-current-buffer (folder &optional create tags)
 205   "Use notmuch insert to put the current buffer in the database.
 206
 207 This inserts the current buffer as a message into the notmuch
 208 database in folder FOLDER. If CREATE is non-nil it will supply
 209 the --create-folder flag to create the folder if necessary. TAGS
 210 should be a list of tag changes to apply to the inserted message."
 211   (let* ((args (append (and create (list "--create-folder"))
 212                        (list (concat "--folder=" folder))
 213                        tags)))
 214     (apply 'notmuch-call-notmuch-process
 215            :stdin-string (buffer-string) "insert" args)))
 216
 217 (defun notmuch-maildir-fcc-with-notmuch-insert (fcc-header &optional create)
 218   "Store message with notmuch insert.
 219
 220 The fcc-header should be of the form \"folder +tag1 -tag2\" where
 221 folder is the folder (relative to the notmuch mailstore) to store
 222 the message in, and tag1 and tag2 are tag changes to apply to the
 223 stored message. This string is split using `split-string-and-unquote',
 224 so a folder name containing spaces can be specified by
 225 quoting each space with an immediately preceding backslash
 226 or surrounding the entire folder name in double quotes.
 227
 228 If CREATE is non-nil then create the folder if necessary."
 229   (pcase-let ((`(,folder . ,tags)
 230                (split-string-and-unquote fcc-header)))
 231     (condition-case nil
 232         (notmuch-maildir-notmuch-insert-current-buffer folder create tags)
 233       ;; Since there are many reasons notmuch insert could fail, e.g.,
 234       ;; locked database, non-existent folder (which could be due to a
 235       ;; typo, or just the user want a new folder, let the user decide
 236       ;; how to deal with it.
 237       (error
 238        (let ((response (read-char-choice "Insert failed: \
 239 \(r)etry, (c)reate folder, (i)gnore, or (e)dit the header? " '(?r ?c ?i ?e))))
 240          (cl-case response
 241            (?r (notmuch-maildir-fcc-with-notmuch-insert fcc-header))
 242            (?c (notmuch-maildir-fcc-with-notmuch-insert fcc-header t))
 243            (?i t)
 244            (?e (notmuch-maildir-fcc-with-notmuch-insert
 245                 (read-from-minibuffer "Fcc header: " fcc-header)))))))))
 246
 247 ;;; Functions for saving a message using file fcc.
 248
 249 (defun notmuch-maildir-fcc-host-fixer (hostname)
 250   (replace-regexp-in-string "/\\|:"
 251                             (lambda (s)
 252                               (cond ((string-equal s "/") "\\057")
 253                                     ((string-equal s ":") "\\072")
 254                                     (t s)))
 255                             hostname
 256                             t
 257                             t))
 258
 259 (defun notmuch-maildir-fcc-make-uniq-maildir-id ()
 260   (let* ((ftime (float-time))
 261          (microseconds (mod (* 1000000 ftime) 1000000))
 262          (hostname (notmuch-maildir-fcc-host-fixer (system-name))))
 263     (cl-incf notmuch-maildir-fcc-count)
 264     (format "%d.%d_%d_%d.%s"
 265             ftime
 266             (emacs-pid)
 267             microseconds
 268             notmuch-maildir-fcc-count
 269             hostname)))
 270
 271 (defun notmuch-maildir-fcc-dir-is-maildir-p (dir)
 272   (and (file-exists-p (concat dir "/cur/"))
 273        (file-exists-p (concat dir "/new/"))
 274        (file-exists-p (concat dir "/tmp/"))))
 275
 276 (defun notmuch-maildir-fcc-create-maildir (path)
 277   (cond ((or (not (file-exists-p path)) (file-directory-p path))
 278          (make-directory (concat path "/cur/") t)
 279          (make-directory (concat path "/new/") t)
 280          (make-directory (concat path "/tmp/") t))
 281         ((file-regular-p path)
 282          (error "%s is a file. Can't create maildir." path))
 283         (t
 284          (error "I don't know how to create a maildir here"))))
 285
 286 (defun notmuch-maildir-fcc-save-buffer-to-tmp (destdir)
 287   "Returns the msg id of the message written to the temp directory
 288 if successful, nil if not."
 289   (let ((msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
 290     (while (file-exists-p (concat destdir "/tmp/" msg-id))
 291       (setq msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
 292     (cond ((notmuch-maildir-fcc-dir-is-maildir-p destdir)
 293            (write-file (concat destdir "/tmp/" msg-id))
 294            msg-id)
 295           (t
 296            (error "Can't write to %s. Not a maildir." destdir)))))
 297
 298 (defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id)
 299   (add-name-to-file
 300    (concat destdir "/tmp/" msg-id)
 301    (concat destdir "/new/" msg-id ":2,")))
 302
 303 (defun notmuch-maildir-fcc-move-tmp-to-cur (destdir msg-id &optional mark-seen)
 304   (add-name-to-file
 305    (concat destdir "/tmp/" msg-id)
 306    (concat destdir "/cur/" msg-id ":2," (and mark-seen "S"))))
 307
 308 (defun notmuch-maildir-fcc-file-fcc (fcc-header)
 309   "Write the message to the file specified by FCC-HEADER.
 310
 311 It offers the user a chance to correct the header, or filesystem,
 312 if needed."
 313   (if (notmuch-maildir-fcc-dir-is-maildir-p fcc-header)
 314       (notmuch-maildir-fcc-write-buffer-to-maildir fcc-header t)
 315     ;; The fcc-header is not a valid maildir see if the user wants to
 316     ;; fix it in some way.
 317     (let* ((prompt (format "Fcc %s is not a maildir: \
 318 \(r)etry, (c)reate folder, (i)gnore, or (e)dit the header? " fcc-header))
 319            (response (read-char-choice prompt '(?r ?c ?i ?e))))
 320       (cl-case response
 321         (?r (notmuch-maildir-fcc-file-fcc fcc-header))
 322         (?c (if (file-writable-p fcc-header)
 323                 (notmuch-maildir-fcc-create-maildir fcc-header)
 324               (message "No permission to create %s." fcc-header)
 325               (sit-for 2))
 326             (notmuch-maildir-fcc-file-fcc fcc-header))
 327         (?i t)
 328         (?e (notmuch-maildir-fcc-file-fcc
 329              (read-from-minibuffer "Fcc header: " fcc-header)))))))
 330
 331 (defun notmuch-maildir-fcc-write-buffer-to-maildir (destdir &optional mark-seen)
 332   "Writes the current buffer to maildir destdir. If mark-seen is
 333 non-nil, it will write it to cur/, and mark it as read. It should
 334 return t if successful, and nil otherwise."
 335   (let ((orig-buffer (buffer-name)))
 336     (with-temp-buffer
 337       (insert-buffer-substring orig-buffer)
 338       (catch 'link-error
 339         (let ((msg-id (notmuch-maildir-fcc-save-buffer-to-tmp destdir)))
 340           (when msg-id
 341             (condition-case nil
 342                 (if mark-seen
 343                     (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t)
 344                   (notmuch-maildir-fcc-move-tmp-to-new destdir msg-id))
 345               (file-already-exists
 346                (throw 'link-error nil))))
 347           (delete-file (concat destdir "/tmp/" msg-id))))
 348       t)))
 349
 350 ;;; _
 351
 352 (provide 'notmuch-maildir-fcc)
 353
 354 ;;; notmuch-maildir-fcc.el ends here