cgit.sxemacs.org Git - gnus/blob - lisp/mml2015.el

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