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

   1 ;; This file is free software; you can redistribute it and/or modify
   2 ;; it under the terms of the GNU General Public License as published
   3 ;; by the Free Software Foundation; either version 2, or (at your
   4 ;; option) any later version.
   5
   6 ;; This program is distributed in the hope that it will be useful,
   7 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
   8 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   9 ;; GNU General Public License for more details.
  10
  11 ;; You should have received a copy of the GNU General Public License
  12 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  13 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  14 ;; Boston, MA 02110-1301, USA.
  15 ;;
  16 ;; To use this as the fcc handler for message-mode,
  17 ;; customize the notmuch-fcc-dirs variable
  18
  19 (require 'message)
  20
  21 (require 'notmuch-lib)
  22
  23 (defvar notmuch-maildir-fcc-count 0)
  24
  25 (defcustom notmuch-fcc-dirs nil
  26  "Determines the maildir directory to save outgoing mails in.
  27
  28  If set to non-nil, this will cause message mode to file your
  29  mail in the specified directory (fcc).
  30
  31  It is either a string if you only need one fcc directory or a
  32  list if they depend on your From address (see example).
  33
  34  In the former case it is a string such as \"INBOX.Sent\".
  35
  36  In the fancy setup, where you want different outboxes depending
  37  on your From address, you supply a list like this:
  38
  39      ((\"defaultinbox\")
  40       (\"Sebastian Spaeth <Sebastian@SSpaeth.de>\" . \"privat\")
  41       (\"Sebastian Spaeth <spaetz@sspaeth.de>\" . \"OUTBOX.OSS\")
  42      )
  43
  44  The outbox that matches a key (case insensitive) will be
  45  used. The first entry is used as a default fallback when nothing
  46  else matches.
  47
  48  In all cases, a relative FCC directory will be understood to
  49  specify a directory within the notmuch mail store, (as set by
  50  the database.path option in the notmuch configuration file).
  51
  52  You will be prompted to create the directory if it does not exist yet when
  53  sending a mail.
  54
  55  This function will not modify the headers if there is a FCC
  56  header, but will check that the target directory exists."
  57
  58  :require 'notmuch-fcc-initialization
  59  :group 'notmuch
  60 )
  61
  62 (defun notmuch-fcc-initialization ()
  63   "If notmuch-fcc-directories is set,
  64    hook them into the message-fcc-handler-function"
  65     ;; Set up the message-fcc-handler to move mails to the maildir in Fcc
  66     ;; The parameter is set to mark messages as "seen"
  67     (setq message-fcc-handler-function
  68           '(lambda (destdir)
  69              (notmuch-maildir-fcc-write-buffer-to-maildir destdir t)))
  70     ;;add a hook to actually insert the Fcc header when sending
  71     (add-hook 'message-send-hook 'notmuch-fcc-header-setup))
  72
  73 (defun notmuch-fcc-header-setup ()
  74   "Adds an appropriate fcc header to the current mail buffer
  75
  76    Can be added to message-send-hook and will set the FCC header
  77    based on the values of notmuch-fcc-directories (see the
  78    variable customization there for examples). It uses the first
  79    entry as default fallback if no From address matches."
  80   ;; only do something if notmuch-fcc-dirs is set
  81   (when notmuch-fcc-dirs
  82     (let (subdir)
  83       (if (stringp notmuch-fcc-dirs)
  84           ;; notmuch-fcc-dirs is a string, just use it as subdir
  85           (setq subdir notmuch-fcc-dirs)
  86         ;; else: it's a list of alists (("sent") ("name1" . "sent1"))
  87         (setq subdir (cdr (assoc-string (message-fetch-field "from") notmuch-fcc-dirs t)))
  88          ;; if we found no hit, use the first entry as default fallback
  89          (unless subdir (setq subdir (car (car notmuch-fcc-dirs)))))
  90
  91   ;; if there is no fcc header yet, add ours
  92   (unless (message-fetch-field "fcc")
  93     (message-add-header (concat "Fcc: "
  94                                 (if (= (elt subdir 0) ?/)
  95                                     subdir
  96                                   (concat (notmuch-database-path) "/" subdir)))))
  97
  98   ;; finally test if fcc points to a valid maildir
  99   (let ((fcc-header (message-fetch-field "fcc")))
 100     (unless (notmuch-maildir-fcc-dir-is-maildir-p fcc-header)
 101       (cond ((not (file-writable-p fcc-header))
 102              (error (format "%s is not a maildir, but you don't have permission to create one." fcc-header)))
 103             ((y-or-n-p (format "%s is not a maildir. Create it? "
 104                                fcc-header))
 105              (notmuch-maildir-fcc-create-maildir fcc-header))
 106             (t
 107              (error "Not sending message."))))))))
 108
 109 (defun notmuch-maildir-fcc-host-fixer (hostname)
 110   (replace-regexp-in-string "/\\|:"
 111                             '(lambda (s)
 112                                (cond ((string-equal s "/") "\\057")
 113                                      ((string-equal s ":") "\\072")
 114                                      (t s)))
 115                             hostname
 116                             t
 117                             t))
 118
 119 (defun notmuch-maildir-fcc-make-uniq-maildir-id ()
 120    (let* ((ct (current-time))
 121           (timeid (+ (* (car ct) 65536) (cadr ct)))
 122           (microseconds (car (cdr (cdr ct))))
 123           (hostname (notmuch-maildir-fcc-host-fixer system-name)))
 124      (setq notmuch-maildir-fcc-count (+ notmuch-maildir-fcc-count 1))
 125      (format "%d.%d_%d_%d.%s"
 126              timeid
 127              (emacs-pid)
 128              microseconds
 129              notmuch-maildir-fcc-count
 130              hostname)))
 131
 132 (defun notmuch-maildir-fcc-dir-is-maildir-p (dir)
 133   (and (file-exists-p (concat dir "/cur/"))
 134        (file-exists-p (concat dir "/new/"))
 135        (file-exists-p (concat dir "/tmp/"))))
 136
 137 (defun notmuch-maildir-fcc-create-maildir (path)
 138   (cond ((or (not (file-exists-p path)) (file-directory-p path))
 139          (make-directory (concat path "/cur/") t)
 140          (make-directory (concat path "/new/") t)
 141          (make-directory (concat path "/tmp/") t))
 142         ((file-regular-p path)
 143          (error "%s is a file. Can't creat maildir." path))
 144         (t
 145          (error "I don't know how to create a maildir here"))))
 146
 147 (defun notmuch-maildir-fcc-save-buffer-to-tmp (destdir)
 148   "Returns the msg id of the message written to the temp directory
 149 if successful, nil if not."
 150   (let ((msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
 151     (while (file-exists-p (concat destdir "/tmp/" msg-id))
 152       (setq msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
 153     (cond ((notmuch-maildir-fcc-dir-is-maildir-p destdir)
 154            (write-file (concat destdir "/tmp/" msg-id))
 155            msg-id)
 156           (t
 157            (error (format "Can't write to %s. Not a maildir."
 158                           destdir))
 159            nil))))
 160
 161 (defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id)
 162   (add-name-to-file
 163    (concat destdir "/tmp/" msg-id)
 164    (concat destdir "/new/" msg-id ":2,")))
 165
 166 (defun notmuch-maildir-fcc-move-tmp-to-cur (destdir msg-id &optional mark-seen)
 167   (add-name-to-file
 168    (concat destdir "/tmp/" msg-id)
 169    (concat destdir "/cur/" msg-id ":2," (when mark-seen "S"))))
 170
 171 (defun notmuch-maildir-fcc-write-buffer-to-maildir (destdir &optional mark-seen)
 172   "Writes the current buffer to maildir destdir. If mark-seen is
 173 non-nil, it will write it to cur/, and mark it as read. It should
 174 return t if successful, and nil otherwise."
 175   (let ((orig-buffer (buffer-name)))
 176     (with-temp-buffer
 177       (insert-buffer-substring orig-buffer)
 178       (catch 'link-error
 179         (let ((msg-id (notmuch-maildir-fcc-save-buffer-to-tmp destdir)))
 180           (when msg-id
 181             (cond (mark-seen
 182                    (condition-case err
 183                        (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t)
 184                      (file-already-exists
 185                       (throw 'link-error nil))))
 186                   (t
 187                    (condition-case err
 188                        (notmuch-maildir-fcc-move-tmp-to-new destdir msg-id)
 189                      (file-already-exists
 190                       (throw 'link-error nil))))))
 191           (delete-file (concat destdir "/tmp/" msg-id))))
 192       t)))
 193
 194 (notmuch-fcc-initialization)
 195 (provide 'notmuch-maildir-fcc)
 196