;; -*- emacs-lisp -*-
;;; message-identities.el --- posting styles for mail messages (rewritten)
;;
;; Description: This code allows you change your identity (signature, from
;; address, x-face, gcc) depending on who you are sending to.
;;
;; Author: Mark Triggs <mst@dishevelled.net>
;; Keywords: news
;; $Id: message-identities.el,v 1.19 2006/09/14 10:23:52 mst Exp $
;;
;; This file 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 2, or (at your option)
;; any later version.
;;
;; This file 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 GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;
;;; Commentary:
;;
;; While gnus's posting styles work well for news, I wanted to be able to set
;; my identity based on the message recipient for mail messages.  This code
;; lets you define 'identities', which are like posting styles but matched
;; against the To: field of the message.
;;
;; Identities are defined by the 'message-identities' variable as below.  Note
;; that identities are applied in a cascading fashion - if identity 1 matches,
;; its settings take effect but if identity 2 also matches, its settings will
;; take effect also.  Headers take the form of (HEADER . VALUE) where VALUE is
;; a form that is evaluated at runtime. Value may reference the free variable
;; TO-ADDRESS, which is the recipient of the message.
;;
;; (setq message-identities
;;       `(
;;         ;; identity 1
;;         ((name . "foobar")
;;          (to . ".*@somehost.com")
;;          (headers . ((gcc . "somegroup")
;;                      (organization . "foo")
;;                      (X-junk . (concat "foo" "bar"))
;;                      (from . "someuser <hello@world.com>")))
;;          (signature-file . "~/.somefile"))
;;
;;         ;; identity 2
;;         ((name . "work")
;;          (to . ".*@workaddress.com")
;;          (headers . ((gcc . "someothergroup")
;;                      (from . "You <somewhere@work.com>")))
;;          (signature-file . ,somevariable))))
;;
;; Calling M-x message-identity-apply from within a message buffer will select
;; identities matching the recipient and apply them. I prefer to have this
;; happen automatically as the message is sent, and use code like:
;;
;;   (add-hook 'message-send-hook 'message-identity-apply)
;;
;; M-x message-identity-clear attempts to remove all identities from the
;; current message.
;;
;; Adding a "gnus-identity" field to a person's BBDB record containing the
;; name of an identity causes that identity to be used when sending messages
;; to that person.
;;
;; To stop certain headers (such as the "From" header) appearing in messages by
;; default, you might like to add the following snippet to your ~/.gnus:
;;
;; (when (boundp 'message-required-headers)
;;   (setq message-required-headers (remove 'From message-required-headers)))
;;

;;; Code:

(defvar message-identities nil
  "Different user 'identities' for outgoing mail messages")

;; Accessors
(defun identity-name (i) (cdr (assoc 'name i)))
(defun identity-regexp (i) (cdr (assoc 'to i)))
(defun identity-headers (i) (cdr (assoc 'headers i)))
(defun identity-signature (i) (cdr (assoc 'signature-file i)))


(defmacro with-narrowed-headers (&rest body)
  `(progn (message-narrow-to-headers)
          (unwind-protect
              ,(cons 'progn body)
            (widen))))


(defun message-has-signature-p ()
  (or (and (boundp 'message-has-signature)
           message-has-signature)
      (save-excursion
        (goto-char (point-min))
        (search-forward "-- \n" nil t))))


(defun message-identity-add (identity)
  "Add IDENTITY to the current message."
  ;; Add headers
  (unless (boundp 'message-added-headers)
    (set (make-local-variable 'message-added-headers) '()))
  (with-narrowed-headers
   (map nil (lambda (header)
              (destructuring-bind (header . value) header
                (unless (member header message-added-headers)
                  (push header message-added-headers)
                  (message-add-header
                   (format "%s: %s"
                           (upcase-initials (format "%s" header))
                           (if (stringp value)
                               value
                             (let ((to-address (message-fetch-field "To")))
                               (eval value))))))))
        (identity-headers identity)))

  ;; Add the signature
  (unless (message-has-signature-p)
    (let ((message-signature t)
          (message-signature-file (identity-signature identity)))
      (set (make-local-variable 'message-has-signature) t)
      (message-insert-signature))))


(defun message-identity-remove (identity)
  "Remove IDENTITY from the current message"
  (with-narrowed-headers
   (map nil (lambda (header)
              (destructuring-bind (header . value) header
                (message-remove-header (format "%s" header))))
        (identity-headers identity)))

  ;; Remove the signature
  (when (message-has-signature-p)
    (flet ((message-goto-signature ()
             (goto-char (point-max))
             (search-backward-regexp "-- $" nil t nil)))
      (save-excursion
        (message-goto-signature)
        (delete-region (1- (point)) (point-max))
        (delete-blank-lines)))))


(defun message-identity-get (name)
  (find-if (lambda (i) (string= (identity-name i) name))
           message-identities))


(defun message-identity-matches (recipient)
  "Return the identities applicable to RECIPIENT.  If the recipient's BBDB
  entry has a 'gnus-identity' field, this is used.  Otherwise,
  MESSAGE-IDENTITIES is searched for a matching regexp."
  (let ((bbdb-field
         (bbdb-search-simple nil (mapcar 'car (ietf-drums-parse-addresses
                                               recipient)))))
    (if (and bbdb-field (bbdb-get-field bbdb-field 'gnus-identity)
             (message-identity-get (bbdb-get-field bbdb-field 'gnus-identity)))
        (list (message-identity-get
               (bbdb-get-field bbdb-field 'gnus-identity)))
      (remove-if-not (lambda (i)
                       (if (identity-regexp i)
                           (string-match (identity-regexp i) recipient)
                         nil))
                     message-identities))))

(defun message-identity-replace ()
  (interactive)
  (message-identity-clear)
  (let ((current-prefix-arg t))
    (call-interactively 'message-identity-apply)))

(defun message-identity-apply (&optional name)
  "Apply the identity NAME to the current message. If NAME is not
provided, an appropriate identity is chosen based on the message
recipient."
  (interactive)
  (when current-prefix-arg
    (setq name (completing-read "Identity: "
                                (mapcar #'(lambda (i)
                                            (cons (cdr (assoc 'name i))
                                                  (cdr (assoc 'name i))))
                                        message-identities))))
  (when (message-mail-p)
    (if (and name (message-identity-get name))
        (message-identity-add (message-identity-get name))
      (map nil #'message-identity-add
           (message-identity-matches
            (with-narrowed-headers (message-fetch-field "To")))))))


(defun message-identity-clear ()
  "Remove gcc, signature, organization and from address headers"
  (interactive)
  (set (make-local-variable 'message-has-signature) nil)
  (set (make-local-variable 'message-added-headers) '())
  (map nil #'message-identity-remove
       (message-identity-matches
        (with-narrowed-headers (or (message-fetch-field "To") "")))))


(provide 'message-identities)