git.chise.org Git - elisp/gnus.git-/blob - contrib/rfc2015.el

   1 ;;; rfc2015.el --- MIME Security with Pretty Good Privacy (PGP)
   2 ;; Copyright (c) 2000 Shenghuo Zhu
   3
   4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   5 ;; Keywords: PGP MIME
   6
   7 ;; This file is not (yet) a part of GNU Emacs. Hope it
   8 ;; will be a part of oGnus distribution, then GNU Emacs.
   9
  10 ;; This file is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published
  12 ;; by the Free Software Foundation; either version 2, or (at your
  13 ;; option) any later version.
  14
  15 ;; This file is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Installation: put the following statements in ~/.gnus:
  28 ;;    (require 'rfc2015)
  29 ;;    (require 'gnus-art)
  30 ;;    (rfc2015-setup)
  31 ;; You may have to make sure that the directory where this file lives
  32 ;; is mentioned in `load-path'.
  33 ;;
  34 ;; Insert an attribute, postprocess=pgp-sign (or pgp-encrypt), into
  35 ;; the mml tag to be signed (or encrypted).
  36
  37 ;;; Code:
  38
  39 (defvar rfc2015-decrypt-function 'mailcrypt-decrypt)
  40 (defvar rfc2015-verify-function 'mailcrypt-verify)
  41
  42 (defun rfc2015-decrypt (handle)
  43   (let (child)
  44     (cond
  45      ((setq child (mm-find-part-by-type (cdr handle)
  46                                         "application/octet-stream"))
  47       (let (handles result)
  48         (with-temp-buffer
  49           (mm-insert-part child)
  50           (setq result (funcall rfc2015-decrypt-function))
  51           (unless (car result)
  52             (error "Decrypting error."))
  53           (setq handles (mm-dissect-buffer t)))
  54         (setq gnus-article-mime-handles
  55               (append (if (listp (car gnus-article-mime-handles))
  56                           gnus-article-mime-handles
  57                         (list gnus-article-mime-handles))
  58                       (if (listp (car handles))
  59                           handles
  60                         (list handles))))
  61         (gnus-mime-display-part handles)))
  62      (t
  63       (if (y-or-n-p "Corrupted pgp-encrypted part. Abort?" )
  64           (error "Corrupted pgp-encrypted part.")
  65         (gnus-mime-display-mixed (cdr handle)))))))
  66
  67 ;; FIXME: mm-dissect-buffer loses information of micalg and the
  68 ;; original header of signed part.
  69
  70 (defun rfc2015-verify (handle)
  71   (if (y-or-n-p "Verify signed part?" )
  72       (let (child result hash)
  73         (with-temp-buffer
  74           (unless (setq child (mm-find-part-by-type
  75                                (cdr handle) "application/pgp-signature" t))
  76             (error "Corrupted pgp-signature part."))
  77           (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
  78           (insert (format "Hash: %s\n\n" (read-string "Hash: " "SHA1")))
  79           (mm-insert-part child)
  80           (goto-char (point-max))
  81           (unless (bolp)
  82             (insert "\n"))
  83           (unless (setq child (mm-find-part-by-type
  84                                (cdr handle) "application/pgp-signature"))
  85             (error "Corrupted pgp-signature part."))
  86           (mm-insert-part child)
  87           (setq result (funcall rfc2015-verify-function))
  88           (unless result
  89             (error "Verify error.")))))
  90   (gnus-mime-display-part
  91    (mm-find-part-by-type
  92     (cdr handle) "application/pgp-signature" t)))
  93
  94 (defvar rfc2015-mailcrypt-prefix 0)
  95
  96 (defun rfc2015-mailcrypt-sign (cont)
  97   (mailcrypt-sign rfc2015-mailcrypt-prefix)
  98   (let ((boundary
  99          (funcall mml-boundary-function (incf mml-multipart-number)))
 100         (scheme-alist (funcall (or mc-default-scheme
 101                                    (cdr (car mc-schemes)))))
 102         hash)
 103     (goto-char (point-min))
 104     (unless (re-search-forward (cdr (assq 'signed-begin-line scheme-alist)))
 105       (error "Cannot find signed begin line." ))
 106     (goto-char (match-beginning 0))
 107     (forward-line 1)
 108     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 109       (error "Cannot not find PGP hash." ))
 110     (setq hash (match-string 1))
 111     (unless (re-search-forward "^$" nil t)
 112       (error "Cannot not find PGP message." ))
 113     (forward-line 1)
 114     (delete-region (point-min) (point))
 115     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 116                     boundary))
 117     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 118                     hash))
 119     (insert "\n")
 120     (insert (format "--%s\n" boundary))
 121     (unless (re-search-forward (cdr (assq 'signed-end-line scheme-alist)))
 122       (error "Cannot find signature part." ))
 123     (goto-char (match-beginning 0))
 124     (unless (re-search-backward "^-+BEGIN" nil t)
 125       (error "Cannot find signature part." ))
 126     (goto-char (match-beginning 0))
 127     (insert (format "--%s\n" boundary))
 128     (insert "Content-Type: application/pgp-signature\n\n")
 129     (goto-char (point-max))
 130     (insert (format "--%s--\n" boundary))
 131     (goto-char (point-max))))
 132
 133 (defun rfc2015-mailcrypt-encrypt (cont)
 134   ;; FIXME:
 135   ;; You have to input the receiptant.
 136   (mailcrypt-encrypt rfc2015-mailcrypt-prefix)
 137   (let ((boundary
 138          (funcall mml-boundary-function (incf mml-multipart-number))))
 139     (goto-char (point-min))
 140     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 141                     boundary))
 142     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 143     (insert (format "--%s\n" boundary))
 144     (insert "Content-Type: application/pgp-encrypted\n\n")
 145     (insert "Version: 1\n\n")
 146     (insert (format "--%s\n" boundary))
 147     (insert "Content-Type: application/octet-stream\n\n")
 148     (goto-char (point-max))
 149     (insert (format "--%s--\n" boundary))
 150     (goto-char (point-max))))
 151
 152 ;; The following code might be moved into mml.el or gnus-art.el.
 153
 154 (defvar mml-postprocess-alist
 155   '(("pgp-sign" . rfc2015-mailcrypt-sign)
 156     ("pgp-encrypt" . rfc2015-mailcrypt-encrypt))
 157   "Alist of postprocess functions.")
 158
 159 (defun mml-postprocess (cont)
 160   (let ((pp (cdr (or (assq 'postprocess cont)
 161                      (assq 'pp cont))))
 162         item)
 163     (if (and pp (setq item (assoc pp mml-postprocess-alist)))
 164         (funcall (cdr item) cont))))
 165
 166 (defun rfc2015-setup ()
 167   (setq mml-generate-mime-postprocess-function 'mml-postprocess)
 168 ;  (push '("multipart/signed" . rfc2015-verify)
 169 ;       gnus-mime-multipart-functions)
 170   (push '("multipart/encrypted" . rfc2015-decrypt)
 171         gnus-mime-multipart-functions))
 172
 173 ;; The following code might be moved into mm-decode.el.
 174
 175 (defun mm-find-part-by-type (handles type &optional notp)
 176   (let (handle)
 177     (while handles
 178       (if (if notp
 179               (not (equal (mm-handle-media-type (car handles)) type))
 180             (equal (mm-handle-media-type (car handles)) type))
 181           (setq handle (car handles)
 182                 handles nil))
 183       (setq handles (cdr handles)))
 184     handle))
 185
 186 (provide 'rfc2015)
 187
 188 ;;; rfc2015.el ends here