;;; gnus-xpgp.el --- create X-PGP-Sig with Gnus and PGG

;; Copyright (C) 2004 Michael Schierl

;; Author: Michael Schierl <schierlm-public@gmx.de>
;; Created: 06 March 2004
;; Keywords: gnus x-pgp-sig pgp pgpverify
;; Version: 0.1

(defconst gnus-xpgp-version "0.1"
  "Version of Gnus X-PGP.")

;; This file is not 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 2, 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 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:

;; Usenet control messages are usually signed - but since the body is
;; read by machines, it would cause problems if they were signed in
;; the body. So there is a special header called X-PGP-Sig to sign
;; these. As a side effect, it is also possible to sign specific
;; headers with this sig as well (which is necessary for control
;; messages, too, to prevent kind of "replay attacks").

;; Both the fact that you can sign headers and that the sig is quite
;; "unobstrusive" (even for non-Gnus news readers) made this kind of
;; signing popular for normal text articles as well. Since the only
;; interface for that I know (x-pgp-sig.el by Katsumi Yamaoka et al.)
;; does not use PGG for its PGP jobs and is quite long (2352 lines) so
;; that it is no fun for me to dig through it, I decided to write my
;; own file for only that purpose - create X-PGP-Sig headers with Gnus
;; and PGG.

;; When this file is set up properly (see Installation below), hit C-c
;; C-f C-x while composing an article to add a special
;; "X-PGP-Signed-Headers" header into your message (You may use any
;; other way of creating headers (like posting styles) as well, of
;; course). All headers mentioned in that header will be signed when
;; sending the message.

;;; Installation:

;; 1. If you want to use these sigs for mail as well, ensure that your
;;    `message-send-mail-function' calls `message-send-mail-hook' -
;;    e.g. `smtpmail-send-it' does not, but `message-smtpmail-send-it'
;;    does.

;; 2. Ensure that PGG is set up properly. In a scratch buffer, write
;;    in some stuff and do a M-x pgg-sign RET. This should result in a
;;    clear-signed message (signed with the key you want to use for
;;    X-PGP-Sig) you can verify.

;; 3. In your .gnus.el file, load this file (add it to the load-path
;;    if it is not there) and call gnus-xpgp-initialize. If this file
;;    is in your load path, you can do this by
;;
;;    (require 'gnus-xpgp)
;;    (gnus-xpgp-initialize)


;;; Bugs:

;; When signing a news article, the local copy in the archive group is
;; not signed.

;;; History:

;; 2004-03-07 First "release" in gnu.emacs.sources

;;; Code:

(require 'gnus)
(require 'message)
(require 'pgg)

(defvar gnus-xpgp-default-fields
   '("Subject" "Control" "Message-ID" "Date" "From" "Sender" "Newsgroups"
     "Followup-To" "Approved" "Supersedes"))

(defvar gnus-xpgp-remove-unused-fields t
  "Whether to remove unused header fields from the X-PGP-Sig header.")

(defvar gnus-xpgp-marker-header "X-PGP-Signed-Headers")
(defvar gnus-xpgp-header "X-PGP-Sig")

(defconst gnus-xpgp-sig-begin
  "^-----BEGIN PGP \\(SIGNATURE\\|MESSAGE\\)-----$")

(defconst gnus-xpgp-sig-end
  "^-----END PGP \\(SIGNATURE\\|MESSAGE\\)-----$")

(defvar mml-mime-encoded-hook nil)

;; i want to see x-pgp-sig as well in preview window
(defadvice mml-to-mime (after gnus-xpgp-mml-to-mime-advice activate)
  "Run `mml-mime-encoded-hook' when finished."
  (run-hooks 'mml-mime-encoded-hook))

;;;###autoload
(defun gnus-xpgp-initialize ()
  "Initialize Gnus X-PGP.
Add `gnus-xpgp-create-sig-maybe' to several hooks and create a key
binding for `gnus-xpgp-add-header'."
  (add-hook 'mml-mime-encoded-hook 'gnus-xpgp-create-sig-maybe)
  (add-hook 'message-send-mail-hook 'gnus-xpgp-create-sig-maybe)
  (add-hook 'message-send-news-hook 'gnus-xpgp-create-sig-maybe)
  (define-key message-mode-map (kbd "C-c C-f C-x") 'gnus-xpgp-add-header))

(defun gnus-xpgp-add-header (arg)
  "Add a PGP sig marker header.
With a prefix ARG, reset its value to the default (all headers
mentioned in `gnus-xpgp-default-fields')."
  (interactive "P")
  (message-position-on-field gnus-xpgp-marker-header "Gcc" "From" "Subject")
  (message-beginning-of-line)
  (if (cond
       ((bolp) ; header was empty
	(message-beginning-of-line)
	t)
       (arg ; prefix arg specified
	(kill-line nil)
	t)
       (t
	(end-of-line)
	nil))
      (insert (mapconcat 'identity gnus-xpgp-default-fields ","))))

(defun gnus-xpgp-create-sig-maybe ()
  "Create a X-PGP sig when a marker header is found in current buffer."
  (save-restriction
    (message-narrow-to-head)
    (let ((hdr (or (mail-fetch-field gnus-xpgp-marker-header) ""))
	  result allheads)
      (unless (string= hdr "")
	(goto-char (point-min))
	(re-search-forward (concat "^" (regexp-quote gnus-xpgp-marker-header)
				   ": "))
	(beginning-of-line)
	(kill-line 1)
	(while (looking-at "^[ \t]") (kill-line 1))
	(save-excursion
	  (save-restriction
	    (if gnus-xpgp-remove-unused-fields
		(setq hdr (gnus-xpgp-remove-unused-headers hdr)))
	    ;; collect all headers
	    (setq allheads (gnus-xpgp-collect-headers hdr))
	    (goto-char (point-max))
	    (widen)
	    (forward-line 1)
	    ;; now I am on the body
	    (let ((buf (current-buffer)) (beg (point)) (end (point-max)))
	      (with-temp-buffer
		(buffer-disable-undo)
		(erase-buffer)
		(insert allheads "\n\n")
		(insert-buffer-substring buf beg end)
		(pgg-sign)
		))
	    (with-current-buffer (get-buffer-create pgg-output-buffer)
	      (goto-char (point-min))
	      (setq result (gnus-xpgp-parse-signature hdr)))))
	(insert result "\n")))))

(defun gnus-xpgp-collect-headers (hdr)
  "Collect all headers mentioned in HDR and return a string of all of them."
  (mapconcat 'identity
	     (append (list (concat "X-Signed-Headers: " hdr))
		     (mapcar
		      (lambda (h)
			(concat h ": "
				(mail-fetch-field h)))
		      (split-string hdr ",")))
	     "\n"))

(defun gnus-xpgp-parse-signature (hdr)
  "Parse PGP signature in current buffer and return X-PGP-Sig header.
HDR specifies which headers have been signed (this must be present
inside the X-PGP-Sig header)"
(let (ver (sig ""))
    (goto-char (point-min))
    (unless (looking-at gnus-xpgp-sig-begin)
      (error "Error occured when signing: No signature found"))
    (forward-line 1)
    (unless (looking-at "^Version: ")
    (error "No PGP Version found in signature"))
    (setq ver (buffer-substring-no-properties (+ (point) 9) (point-at-eol)))
    (setq ver (gnus-xpgp-clean-version ver))
    (forward-line 2)
    (while (not (or (looking-at
		     gnus-xpgp-sig-end)
		    (eobp)))
      (setq sig
	    (concat sig "\n "
		    (buffer-substring-no-properties (point) (point-at-eol))))
      (forward-line 1))
    (unless (looking-at gnus-xpgp-sig-end)
      (error "No ending ascii armor found"))
    (concat gnus-xpgp-header ": " ver " " hdr sig)))

(defun gnus-xpgp-remove-unused-headers (hdr)
  "Remove unused headers from HDR.
Result is a string with only those headers which are present in
current buffer (which is expected to be narrowed to only the headers)."
  (mapconcat 'identity
	     (remove nil (mapcar
			  (lambda (h)
			    (and (mail-fetch-field h)
				 h))
			  (split-string hdr ",")))
	     ","))
				    

(defun gnus-xpgp-clean-version (ver)
  "Make version VER suitable for X-PGP-Sig headers."
  (while (string-match " " ver)
    (setq ver (replace-match "_" nil t ver)))
  (substring ver 0 (min 32 (length ver))))

(provide 'gnus-xpgp)

;;; gnus-xpgp.el ends here