;; -*- emacs-lisp -*-
;;; gnus-mst-identities.el --- posting styles replacement

;; 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: gnus-mst-identities.el,v 1.40 2004/01/04 05:16:34 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 receipient 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 'gnus-mst-styles' 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 gnus-mst-styles
;;       '(
;;         ;; 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 . "~/.someotherfile"))))

;;; Code:

(defvar gnus-mst-styles nil "Posting styles")

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

(defun message-mst-add-custom-headers (&optional identity)
  "Add a custom headers to outgoing messages depending on destination"
  (ignore-errors
    (when (message-mail-p)
      (let ((to-header (with-narrowed-headers (message-fetch-field "To"))))
        (when to-header
          (let* ((components (mail-extract-address-components to-header t))
                 (to-string (mapconcat 'cadr components ", ")))
            (if (boundp 'identity)
                (message-mst-do-custom-headers to-string identity)
              (message-mst-do-custom-headers to-string))))))))

(defun message-mst-clear-custom-headers ()
  "Remove gcc, signature, organization and from address headers"
  (interactive)
  (let* ((vars (apropos-internal "message-has"))
         (headers (mapcar
                   (lambda (str)
                     (replace-regexp-in-string "message-has-" ""
                                               (symbol-name str)))
                   vars)))
    ;; kill the sig
    (save-excursion
      (goto-char (point-max))
      (ignore-errors (search-backward-regexp "^-- *$"))
      (kill-region (point) (point-max)))

    (with-narrowed-headers
     (mapc (lambda (header) (message-remove-header header))
           headers))

    (mapc (lambda (var) (set var nil))
          vars)))

(defun message-mst-do-custom-headers (to-address &optional identity)
  "Dynamically generate message headers based on recipients"
  (let ((use-styles
         (if (and identity (assoc `(name . ,identity) gnus-mst-styles))
             (list (assoc `(name . ,identity) gnus-mst-styles))
           (remove-if-not (lambda (style) (string-match (cdr (assoc 'to style))
                                                        to-address))
                          gnus-mst-styles))))
    (mapc
     (lambda (style)
       (mapc
        (lambda (field)
          (case (car field)
            (headers (mapc
                      (lambda (header)
                        (let ((sym (intern (upcase (format "message-has-%s"
                                                           (car header))))))
                          (unless (and (boundp sym) (symbol-value sym))
                            (message-add-header
                             (concat
                              (upcase-initials (symbol-name (car header))) ": "
                              (or (and (consp (eval (cdr header)))
                                       (mapconcat (lambda (n) (format "%s" n))
                                                  (eval (cdr header)) ", "))
                                  (format "%s" (eval (cdr header))))))
                            (make-variable-buffer-local sym)
                            (set sym t))))
                      (cdr field)))
            (signature-file
             (message-mst-add-signature (eval (cdr field))))))
        style))
     use-styles)))


(defun message-mst-add-signature (signature-file)
  "Add a signature to a message if one has not already been added"

  (let ((message-signature-file signature-file))
    (unless (or (and (boundp 'message-has-signature)
                     message-has-signature)
                (save-excursion (message-goto-signature)))
      (message-insert-signature t)

      (make-variable-buffer-local 'message-has-signature)
      (setq message-has-signature t))))

(defun message-mst-apply-identity ()
  "prompt for an identity and apply it"
  (interactive)

  (message-mst-add-custom-headers
   (completing-read "apply identity: "
                    (mapcar
                     (lambda (n) (cons (cdr n) (car n)))
                     (mapcar 'car gnus-mst-styles)))))

(provide 'gnus-mst-identities)