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

   1 ;;; notmuch-maildir-fcc.el --- inserting using a fcc handler
   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            (let* ((from (message-field-value "From"))
 111                   (match
 112                    (catch 'first-match
 113                      (dolist (re-folder notmuch-fcc-dirs)
 114                        (when (string-match-p (car re-folder) from)
 115                          (throw 'first-match re-folder))))))
 116              (if match
 117                  (cdr match)
 118                (message "No Fcc header added.")
 119                nil)))
 120           (t
 121            (error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)")))))
 122     (when subdir
 123       (if notmuch-maildir-use-notmuch-insert
 124           (notmuch-maildir-add-notmuch-insert-style-fcc-header subdir)
 125         (notmuch-maildir-add-file-style-fcc-header subdir)))))
 126
 127 (defun notmuch-maildir-add-notmuch-insert-style-fcc-header (subdir)
 128   ;; Notmuch insert does not accept absolute paths, so check the user
 129   ;; really want this header inserted.
 130   (when (or (not (= (elt subdir 0) ?/))
 131             (y-or-n-p
 132              (format "Fcc header %s is an absolute path and notmuch insert is requested.
 133 Insert header anyway? " subdir)))
 134     (message-add-header (concat "Fcc: " subdir))))
 135
 136 (defun notmuch-maildir-add-file-style-fcc-header (subdir)
 137   (message-add-header
 138    (concat "Fcc: "
 139            (file-truename
 140             ;; If the resulting directory is not an absolute path,
 141             ;; prepend the standard notmuch database path.
 142             (if (= (elt subdir 0) ?/)
 143                 subdir
 144               (concat (notmuch-database-path) "/" subdir))))))
 145
 146 ;;; Functions for saving a message using either method.
 147
 148 (defmacro with-temporary-notmuch-message-buffer (&rest body)
 149   "Set-up a temporary copy of the current message-mode buffer."
 150   `(let ((case-fold-search t)
 151          (buf (current-buffer))
 152          (mml-externalize-attachments message-fcc-externalize-attachments))
 153      (with-current-buffer (get-buffer-create " *message temp*")
 154        (erase-buffer)
 155        (insert-buffer-substring buf)
 156        ,@body)))
 157
 158 (defun notmuch-maildir-setup-message-for-saving ()
 159   "Setup message for saving. Should be called on a temporary copy.
 160
 161 This is taken from the function message-do-fcc."
 162   (message-encode-message-body)
 163   (save-restriction
 164     (message-narrow-to-headers)
 165     (mail-encode-encoded-word-buffer))
 166   (goto-char (point-min))
 167   (when (re-search-forward
 168          (concat "^" (regexp-quote mail-header-separator) "$")
 169          nil t)
 170     (replace-match "" t t )))
 171
 172 (defun notmuch-maildir-message-do-fcc ()
 173   "Process Fcc headers in the current buffer.
 174
 175 This is a rearranged version of message mode's message-do-fcc."
 176   (let (list file)
 177     (save-excursion
 178       (save-restriction
 179         (message-narrow-to-headers)
 180         (setq file (message-fetch-field "fcc" t)))
 181       (when file
 182         (with-temporary-notmuch-message-buffer
 183          (save-restriction
 184            (message-narrow-to-headers)
 185            (while (setq file (message-fetch-field "fcc" t))
 186              (push file list)
 187              (message-remove-header "fcc" nil t)))
 188          (notmuch-maildir-setup-message-for-saving)
 189          ;; Process FCC operations.
 190          (while list
 191            (setq file (pop list))
 192            (notmuch-fcc-handler file))
 193          (kill-buffer (current-buffer)))))))
 194
 195 (defun notmuch-fcc-handler (fcc-header)
 196   "Store message with notmuch insert or normal (file) fcc.
 197
 198 If `notmuch-maildir-use-notmuch-insert' is set then store the
 199 message using notmuch insert. Otherwise store the message using
 200 normal fcc."
 201   (message "Doing Fcc...")
 202   (if notmuch-maildir-use-notmuch-insert
 203       (notmuch-maildir-fcc-with-notmuch-insert fcc-header)
 204     (notmuch-maildir-fcc-file-fcc fcc-header)))
 205
 206 ;;; Functions for saving a message using notmuch insert.
 207
 208 (defun notmuch-maildir-notmuch-insert-current-buffer (folder &optional create tags)
 209   "Use notmuch insert to put the current buffer in the database.
 210
 211 This inserts the current buffer as a message into the notmuch
 212 database in folder FOLDER. If CREATE is non-nil it will supply
 213 the --create-folder flag to create the folder if necessary. TAGS
 214 should be a list of tag changes to apply to the inserted message."
 215   (let* ((args (append (and create (list "--create-folder"))
 216                        (list (concat "--folder=" folder))
 217                        tags)))
 218     (apply 'notmuch-call-notmuch-process
 219            :stdin-string (buffer-string) "insert" args)))
 220
 221 (defun notmuch-maildir-fcc-with-notmuch-insert (fcc-header &optional create)
 222   "Store message with notmuch insert.
 223
 224 The fcc-header should be of the form \"folder +tag1 -tag2\" where
 225 folder is the folder (relative to the notmuch mailstore) to store
 226 the message in, and tag1 and tag2 are tag changes to apply to the
 227 stored message. This string is split using `split-string-and-unquote',
 228 so a folder name containing spaces can be specified by
 229 quoting each space with an immediately preceding backslash
 230 or surrounding the entire folder name in double quotes.
 231
 232 If CREATE is non-nil then create the folder if necessary."
 233   (let* ((args (split-string-and-unquote fcc-header))
 234          (folder (car args))
 235          (tags (cdr args)))
 236     (condition-case nil
 237         (notmuch-maildir-notmuch-insert-current-buffer folder create tags)
 238       ;; Since there are many reasons notmuch insert could fail, e.g.,
 239       ;; locked database, non-existent folder (which could be due to a
 240       ;; typo, or just the user want a new folder, let the user decide
 241       ;; how to deal with it.
 242       (error
 243        (let ((response (read-char-choice "Insert failed: \
 244 \(r)etry, (c)reate folder, (i)gnore, or (e)dit the header? " '(?r ?c ?i ?e))))
 245          (cl-case response
 246            (?r (notmuch-maildir-fcc-with-notmuch-insert fcc-header))
 247            (?c (notmuch-maildir-fcc-with-notmuch-insert fcc-header t))
 248            (?i t)
 249            (?e (notmuch-maildir-fcc-with-notmuch-insert
 250                 (read-from-minibuffer "Fcc header: " fcc-header)))))))))
 251
 252 ;;; Functions for saving a message using file fcc.
 253
 254 (defun notmuch-maildir-fcc-host-fixer (hostname)
 255   (replace-regexp-in-string "/\\|:"
 256                             (lambda (s)
 257                               (cond ((string-equal s "/") "\\057")
 258                                     ((string-equal s ":") "\\072")
 259                                     (t s)))
 260                             hostname
 261                             t
 262                             t))
 263
 264 (defun notmuch-maildir-fcc-make-uniq-maildir-id ()
 265   (let* ((ftime (float-time))
 266          (microseconds (mod (* 1000000 ftime) 1000000))
 267          (hostname (notmuch-maildir-fcc-host-fixer (system-name))))
 268     (setq notmuch-maildir-fcc-count (+ notmuch-maildir-fcc-count 1))
 269     (format "%d.%d_%d_%d.%s"
 270             ftime
 271             (emacs-pid)
 272             microseconds
 273             notmuch-maildir-fcc-count
 274             hostname)))
 275
 276 (defun notmuch-maildir-fcc-dir-is-maildir-p (dir)
 277   (and (file-exists-p (concat dir "/cur/"))
 278        (file-exists-p (concat dir "/new/"))
 279        (file-exists-p (concat dir "/tmp/"))))
 280
 281 (defun notmuch-maildir-fcc-create-maildir (path)
 282   (cond ((or (not (file-exists-p path)) (file-directory-p path))
 283          (make-directory (concat path "/cur/") t)
 284          (make-directory (concat path "/new/") t)
 285          (make-directory (concat path "/tmp/") t))
 286         ((file-regular-p path)
 287          (error "%s is a file. Can't create maildir." path))
 288         (t
 289          (error "I don't know how to create a maildir here"))))
 290
 291 (defun notmuch-maildir-fcc-save-buffer-to-tmp (destdir)
 292   "Returns the msg id of the message written to the temp directory
 293 if successful, nil if not."
 294   (let ((msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
 295     (while (file-exists-p (concat destdir "/tmp/" msg-id))
 296       (setq msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
 297     (cond ((notmuch-maildir-fcc-dir-is-maildir-p destdir)
 298            (write-file (concat destdir "/tmp/" msg-id))
 299            msg-id)
 300           (t
 301            (error (format "Can't write to %s. Not a maildir."
 302                           destdir))
 303            nil))))
 304
 305 (defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id)
 306   (add-name-to-file
 307    (concat destdir "/tmp/" msg-id)
 308    (concat destdir "/new/" msg-id ":2,")))
 309
 310 (defun notmuch-maildir-fcc-move-tmp-to-cur (destdir msg-id &optional mark-seen)
 311   (add-name-to-file
 312    (concat destdir "/tmp/" msg-id)
 313    (concat destdir "/cur/" msg-id ":2," (and mark-seen "S"))))
 314
 315 (defun notmuch-maildir-fcc-file-fcc (fcc-header)
 316   "Write the message to the file specified by FCC-HEADER.
 317
 318 It offers the user a chance to correct the header, or filesystem,
 319 if needed."
 320   (if (notmuch-maildir-fcc-dir-is-maildir-p fcc-header)
 321       (notmuch-maildir-fcc-write-buffer-to-maildir fcc-header t)
 322     ;; The fcc-header is not a valid maildir see if the user wants to
 323     ;; fix it in some way.
 324     (let* ((prompt (format "Fcc %s is not a maildir: \
 325 \(r)etry, (c)reate folder, (i)gnore, or (e)dit the header? " fcc-header))
 326            (response (read-char-choice prompt '(?r ?c ?i ?e))))
 327       (cl-case response
 328         (?r (notmuch-maildir-fcc-file-fcc fcc-header))
 329         (?c (if (file-writable-p fcc-header)
 330                 (notmuch-maildir-fcc-create-maildir fcc-header)
 331               (message "No permission to create %s." fcc-header)
 332               (sit-for 2))
 333             (notmuch-maildir-fcc-file-fcc fcc-header))
 334         (?i t)
 335         (?e (notmuch-maildir-fcc-file-fcc
 336              (read-from-minibuffer "Fcc header: " fcc-header)))))))
 337
 338 (defun notmuch-maildir-fcc-write-buffer-to-maildir (destdir &optional mark-seen)
 339   "Writes the current buffer to maildir destdir. If mark-seen is
 340 non-nil, it will write it to cur/, and mark it as read. It should
 341 return t if successful, and nil otherwise."
 342   (let ((orig-buffer (buffer-name)))
 343     (with-temp-buffer
 344       (insert-buffer-substring orig-buffer)
 345       (catch 'link-error
 346         (let ((msg-id (notmuch-maildir-fcc-save-buffer-to-tmp destdir)))
 347           (when msg-id
 348             (cond (mark-seen
 349                    (condition-case err
 350                        (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t)
 351                      (file-already-exists
 352                       (throw 'link-error nil))))
 353                   (t
 354                    (condition-case err
 355                        (notmuch-maildir-fcc-move-tmp-to-new destdir msg-id)
 356                      (file-already-exists
 357                       (throw 'link-error nil))))))
 358           (delete-file (concat destdir "/tmp/" msg-id))))
 359       t)))
 360
 361 ;;; _
 362
 363 (provide 'notmuch-maildir-fcc)
 364
 365 ;;; notmuch-maildir-fcc.el ends here