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

   1 ;;; notmuch-maildir-fcc.el ---
   2
   3 ;; This file is free software; you can redistribute it and/or modify
   4 ;; it under the terms of the GNU General Public License as published
   5 ;; by the Free Software Foundation; either version 2, or (at your
   6 ;; option) any later version.
   7
   8 ;; This program is distributed in the hope that it will be useful,
   9 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ;; GNU General Public License for more details.
  12
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  15 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 ;; Boston, MA 02110-1301, USA.
  17
  18 ;;; Commentary:
  19
  20 ;; To use this as the fcc handler for message-mode,
  21 ;; customize the notmuch-fcc-dirs variable
  22
  23 ;;; Code:
  24
  25 (eval-when-compile (require 'cl))
  26 (require 'message)
  27
  28 (require 'notmuch-lib)
  29
  30 (defvar notmuch-maildir-fcc-count 0)
  31
  32 (defcustom notmuch-fcc-dirs "sent"
  33  "Determines the maildir directory in which to save outgoing mail.
  34
  35 Three types of values are permitted:
  36
  37 - nil: no Fcc header is added,
  38
  39 - a string: the value of `notmuch-fcc-dirs' is the name of the
  40   folder to use,
  41
  42 - a list: the folder is chosen based on the From address of the
  43   current message using a list of regular expressions and
  44   corresponding folders:
  45
  46      ((\"Sebastian@SSpaeth.de\" . \"privat\")
  47       (\"spaetz@sspaeth.de\" . \"OUTBOX.OSS\")
  48       (\".*\" . \"defaultinbox\"))
  49
  50   If none of the regular expressions match the From address, no
  51   Fcc header will be added.
  52
  53 In all cases, a relative FCC directory will be understood to
  54 specify a directory within the notmuch mail store, (as set by
  55 the database.path option in the notmuch configuration file).
  56
  57 You will be prompted to create the directory if it does not exist
  58 yet when sending a mail."
  59
  60  :type '(choice
  61          (const :tag "No FCC header" nil)
  62          (string :tag "A single folder")
  63          (repeat :tag "A folder based on the From header"
  64                  (cons regexp (string :tag "Folder"))))
  65  :require 'notmuch-fcc-initialization
  66  :group 'notmuch-send)
  67
  68 (defun notmuch-fcc-handler (destdir)
  69   "Write buffer to `destdir', marking it as sent
  70
  71 Intended to be dynamically bound to `message-fcc-handler-function'"
  72     (notmuch-maildir-fcc-write-buffer-to-maildir destdir t))
  73
  74 (defun notmuch-fcc-header-setup ()
  75   "Add an Fcc header to the current message buffer.
  76
  77 Sets the Fcc header based on the values of `notmuch-fcc-dirs'.
  78
  79 Originally intended to be use a hook function, but now called directly
  80 by notmuch-mua-mail"
  81
  82   (let ((subdir
  83          (cond
  84           ((or (not notmuch-fcc-dirs)
  85                (message-field-value "Fcc"))
  86            ;; Nothing set or an existing header.
  87            nil)
  88
  89           ((stringp notmuch-fcc-dirs)
  90            notmuch-fcc-dirs)
  91
  92           ((and (listp notmuch-fcc-dirs)
  93                 (stringp (car notmuch-fcc-dirs)))
  94            ;; Old style - no longer works.
  95            (error "Invalid `notmuch-fcc-dirs' setting (old style)"))
  96
  97           ((listp notmuch-fcc-dirs)
  98            (let* ((from (message-field-value "From"))
  99                   (match
 100                    (catch 'first-match
 101                      (dolist (re-folder notmuch-fcc-dirs)
 102                        (when (string-match-p (car re-folder) from)
 103                          (throw 'first-match re-folder))))))
 104              (if match
 105                  (cdr match)
 106                (message "No Fcc header added.")
 107                nil)))
 108
 109           (t
 110            (error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)")))))
 111
 112     (when subdir
 113       (message-add-header
 114        (concat "Fcc: "
 115                (file-truename
 116                 ;; If the resulting directory is not an absolute path,
 117                 ;; prepend the standard notmuch database path.
 118                 (if (= (elt subdir 0) ?/)
 119                     subdir
 120                   (concat (notmuch-database-path) "/" subdir)))))
 121
 122       ;; finally test if fcc points to a valid maildir
 123       (let ((fcc-header (message-field-value "Fcc")))
 124         (unless (notmuch-maildir-fcc-dir-is-maildir-p fcc-header)
 125           (cond ((not (file-writable-p fcc-header))
 126                  (error (format "No permission to create %s, which does not exist"
 127                                 fcc-header)))
 128                 ((y-or-n-p (format "%s is not a maildir. Create it? "
 129                                    fcc-header))
 130                  (notmuch-maildir-fcc-create-maildir fcc-header))
 131                 (t
 132                  (error "Message not sent"))))))))
 133
 134 (defun notmuch-maildir-fcc-host-fixer (hostname)
 135   (replace-regexp-in-string "/\\|:"
 136                             (lambda (s)
 137                               (cond ((string-equal s "/") "\\057")
 138                                     ((string-equal s ":") "\\072")
 139                                     (t s)))
 140                             hostname
 141                             t
 142                             t))
 143
 144 (defun notmuch-maildir-fcc-make-uniq-maildir-id ()
 145    (let* ((ftime (float-time))
 146           (microseconds (mod (* 1000000 ftime) 1000000))
 147           (hostname (notmuch-maildir-fcc-host-fixer system-name)))
 148      (setq notmuch-maildir-fcc-count (+ notmuch-maildir-fcc-count 1))
 149      (format "%d.%d_%d_%d.%s"
 150              ftime
 151              (emacs-pid)
 152              microseconds
 153              notmuch-maildir-fcc-count
 154              hostname)))
 155
 156 (defun notmuch-maildir-fcc-dir-is-maildir-p (dir)
 157   (and (file-exists-p (concat dir "/cur/"))
 158        (file-exists-p (concat dir "/new/"))
 159        (file-exists-p (concat dir "/tmp/"))))
 160
 161 (defun notmuch-maildir-fcc-create-maildir (path)
 162   (cond ((or (not (file-exists-p path)) (file-directory-p path))
 163          (make-directory (concat path "/cur/") t)
 164          (make-directory (concat path "/new/") t)
 165          (make-directory (concat path "/tmp/") t))
 166         ((file-regular-p path)
 167          (error "%s is a file. Can't create maildir." path))
 168         (t
 169          (error "I don't know how to create a maildir here"))))
 170
 171 (defun notmuch-maildir-fcc-save-buffer-to-tmp (destdir)
 172   "Returns the msg id of the message written to the temp directory
 173 if successful, nil if not."
 174   (let ((msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
 175     (while (file-exists-p (concat destdir "/tmp/" msg-id))
 176       (setq msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
 177     (cond ((notmuch-maildir-fcc-dir-is-maildir-p destdir)
 178            (write-file (concat destdir "/tmp/" msg-id))
 179            msg-id)
 180           (t
 181            (error (format "Can't write to %s. Not a maildir."
 182                           destdir))
 183            nil))))
 184
 185 (defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id)
 186   (add-name-to-file
 187    (concat destdir "/tmp/" msg-id)
 188    (concat destdir "/new/" msg-id ":2,")))
 189
 190 (defun notmuch-maildir-fcc-move-tmp-to-cur (destdir msg-id &optional mark-seen)
 191   (add-name-to-file
 192    (concat destdir "/tmp/" msg-id)
 193    (concat destdir "/cur/" msg-id ":2," (when mark-seen "S"))))
 194
 195 (defun notmuch-maildir-fcc-write-buffer-to-maildir (destdir &optional mark-seen)
 196   "Writes the current buffer to maildir destdir. If mark-seen is
 197 non-nil, it will write it to cur/, and mark it as read. It should
 198 return t if successful, and nil otherwise."
 199   (let ((orig-buffer (buffer-name)))
 200     (with-temp-buffer
 201       (insert-buffer-substring orig-buffer)
 202       (catch 'link-error
 203         (let ((msg-id (notmuch-maildir-fcc-save-buffer-to-tmp destdir)))
 204           (when msg-id
 205             (cond (mark-seen
 206                    (condition-case err
 207                        (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t)
 208                      (file-already-exists
 209                       (throw 'link-error nil))))
 210                   (t
 211                    (condition-case err
 212                        (notmuch-maildir-fcc-move-tmp-to-new destdir msg-id)
 213                      (file-already-exists
 214                       (throw 'link-error nil))))))
 215           (delete-file (concat destdir "/tmp/" msg-id))))
 216       t)))
 217
 218 (provide 'notmuch-maildir-fcc)
 219
 220 ;;; notmuch-maildir-fcc.el ends here