;;; mail-queue.el --- Message queuer for `mail-mode'.

;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010  Alfred M. Szmidt

;; This file is not (yet) part of GNU Emacs.

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of the
;; License, or (at your option) any later version.

;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
;; USA

;;; Code:
(require 'sendmail)

(defgroup mail-queue nil
  "Mail queuing system for Emacs."
  :group 'mail)

(defcustom mail-queue-directory (expand-file-name
				 "mail-queue" "~/.emacs.d")
  "Directory to store queued messages in."
  :type '(string)
  :group 'mail-queue)

(defcustom mail-queue-file-suffix ".qm"
  "File suffix to use for queued messages."
  :type '(string)
  :group 'mail-queue)

(defcustom mail-queue-warning-limit 10
  "If there is more than this many messages in the queue, warn
the user that it is time to flush the queue."
  :type '(int)
  :group 'mail-queue)

;;; Helper functions (not visible to the outside):

(defun mail-queue-file-p (file)
  "Return t if FILE is a mail-queue file."
  (cond ((file-directory-p file) nil)
 	((file-symlink-p file) nil)	; Ignore possible lock files.
	((backup-file-name-p file) nil)
 	((string-match (file-name-extension file t)
		       mail-queue-file-suffix) t)
	(t nil)))

(defun mail-queue-get-subject-line ()
  "Get the subject of a buffer, and remove characters that are
unsafe in file names."
  (goto-char (point-min))
  (re-search-forward "^Subject: ")
  (let ((point-start (point)))
    (end-of-line)
    (let ((subject (buffer-substring point-start (point))))
      (while (string-match "[^a-z0-9-]+" subject)
 	(setq subject (replace-match "-" nil nil subject)))
      (while (string-match "--+" subject)
 	(setq subject (replace-match "-" nil nil subject)))
      (when (string-match "^-*" subject)
 	(setq subject (replace-match "" nil nil subject)))
      (when (string-match "-*$" subject)
 	(setq subject (replace-match "" nil nil subject)))
      (when (zerop (length subject))
 	(error "No subject given"))
      subject)))

(defun mail-queue-generate-file-name ()
  "Returns a file name that is unique `mail-queue' file name."
  (let* ((count 0)
	 (subject (mail-queue-get-subject-line))
	 (file-name (format "%d-%s%s" count subject mail-queue-file-suffix)))
    (while (and (mail-queue-file-p file-name)
		(file-exists-p (expand-file-name
				file-name mail-queue-directory)))
      (setq count (1+ count))
      (setq file-name (format "%d-%s%s"
			      count subject mail-queue-file-suffix)))
    (expand-file-name file-name mail-queue-directory)))

(defun mail-queue-do-queue (function)
  "Apply FUNCTION to each mail-queue file, returns how many
times FUNCTION was invoked."
  (let ((count 0))
    (dolist (file (directory-files mail-queue-directory t))
      (when (and (mail-queue-file-p file) function)
	(funcall function file)
	(setq count (1+ count))))
    count))

(defun mail-queue-flush-file (file)
  (let ((already-buffer (find-buffer-visiting file))
	(buffer (generate-new-buffer file))
	(buffer-file-coding-system 'utf-8-unix))
    (when (and already-buffer (buffer-modified-p already-buffer))
      (save-window-excursion
	(display-buffer (set-buffer already-buffer))
 	(when (y-or-n-p "Save before queueing the message? ")
 	  (save-buffer))))
    (save-window-excursion
      (set-buffer buffer)
      (erase-buffer)
      (setq buffer-offer-save nil)
      (buffer-disable-undo buffer)
      (insert-file-contents-literally file)
      (mail-mode)
      (mail-send)
      (rename-file file (car (find-backup-file-name file)))
      (message "Sent %s." file))))

(defun mail-queue-local-flush ()
  (message "All sent, flushed %d message(s)." 
	   (mail-queue-do-queue 'mail-queue-flush-file)))

(defun mail-queue-remote-flush (host)
  (error "Remote flushing of the mail queue is not implemented"))

;;; Experimental cruft that doesn't really work
;;
;;To flush on a host:
;; lsh HOST emacs -q --no-site-file -batch -l mail-queue -f mail-queue-local-flush
;;
;; Fetching mail from remote host:
;;
;;  cronjob on REMOTE that copies mail spool to a unique name.
;;  LOCAL does a rsync of all mail spool files from remote
;;
;; Race:
;;
;;  mail-queue-move
;;
;;  create new message that has the same file name as one message that was moved 
;;
;;  mail-queue-move -- should warn, error or rename the file uniquley on target


;; (setq mail-queue-remote-directory
;;       (concat "/ssh:foo:" mail-queue-directory))
;; (setq mail-queue-extra-remote-files nil)

;; (defun mail-queue-move-file (file)
;;   (message "Copying %s to %s..." file mail-queue-remote-directory)
;;   (copy-file file mail-queue-remote-directory)
;;   (message "Renaming %s to %s.." file (find-backup-file-name file))
;;   (rename-file file (find-backup-file-name file))
;;   ;; Copy user specific files to remote host; overwrite possible
;;   ;; copies on the remote host.
;;   (dolist (x mail-queue-extra-remote-files)
;;     (copy-file x (concat host x))
;;     (message "Copying %s to %s..." x (concat host  x))))

;; ;;;###autoload
;; (defun mail-queue-move ()
;;   (interactive)
;;   (let ((count (mail-queue-do-queue
;; 		#'(lambda (file) 'mail-queue-move-file file))))
;;     (message "Moved %d message(s)." mail-count)))

;;; Interactive functions:

;;;###autoload
(defun mail-queue-mode (&optional arg)
  "Toggle Mail Queue mode.
With `arg', turn Mail Queue mode on if `arg' is positive, off
otherwise."
  (interactive)
  ;; Save `send-mail-function' when enabling mail-queue mode, store it
  ;; when disabling.
  (if arg
      (progn
	(unless old-send-mail-function
	  (setq old-send-mail-function send-mail-function))
	(setq send-mail-function 'mail-queue-send-it)
	(message "Mail-Queue mode enabled"))
    (when old-send-mail-function
      (setq send-mail-function old-send-mail-function))
    (message "Mail-Queue mode disabled")))

;;;###autoload
(defvar old-send-mail-function nil)

;;;###autoload
(defun mail-queue-send-it ()
  "Send the current mail buffer using the Mail Queue package.
This is a suitable value for `send-mail-function'.  It puts the
message into the users mail queue.

The function does not really send the message, it saves it in
`mail-queue-directory' under a unique name."
  (interactive)
  (when (not (file-accessible-directory-p mail-queue-directory))
    (make-directory mail-queue-directory t))
  ;; Find and handle any FCC fields.
  (progn
    (goto-char (mail-header-end))
    (let ((delimline (point-marker)))
      (goto-char (point-min))
      (when (re-search-forward "^FCC:" delimline t)
	(mail-do-fcc delimline))))
  (write-file (mail-queue-generate-file-name))
  (kill-buffer (current-buffer))
  (let ((count (mail-queue-do-queue #'(lambda (ignore) ignore))))
    (if (and (not (zerop count)) (> count mail-queue-warning-limit))
	(message "Message queued, it is time to flush the queue.")
      (message "Message queued."))))

;;;###autoload
(defun mail-queue-resend ()
  "Resend message."
  (interactive)
  (rmail-reply t)
  (insert "[I sent this message a few weeks ago but did not get a response.
Could we get the discussion moving again?]\n\n")
  (mail-yank-original nil)
  (mail-send))

(defun mail-queue-show ()
  "Inform the user how many messages are in the mail queue."
  (interactive)
  (message "There are %d messages in the queue."
	   (mail-queue-do-queue #'(lambda (ignore) ignore))))

;;;###autoload
(defun mail-queue-flush (&optional host)
  "Flush the mail queue."
  (interactive (when current-prefix-arg
		 (list (read-file-name "Remote host: "))))
  (if host
      (mail-queue-remote-flush host)
    (mail-queue-local-flush)))

;;; Keybindings.

(define-key mail-mode-map "\C-cqi" 'mail-queue-send-it)
(define-key mail-mode-map "\C-cqs" 'mail-queue-show)
(define-key mail-mode-map "\C-cqf" 'mail-queue-flush)
(define-key mail-mode-map "\C-cqr" 'mail-queue-resend)

(provide 'mail-queue)

;; Local Variables:
;; mode: emacs-lisp
;; End:

;;; `mail-queue.el' ends here.