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 (eval-when-compile (require 'cl))
  39 (require 'mm-decode)
  40
  41 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
  42 (defvar mml2015-verify-function 'mailcrypt-verify)
  43 (defvar mml2015-encrypt-function 'mml2015-mailcrypt-encrypt)
  44 (defvar mml2015-sign-function 'mml2015-mailcrypt-sign)
  45
  46 ;;;###autoload
  47 (defun mml2015-decrypt (handle ctl)
  48   (let (child handles result)
  49     (unless (setq child (mm-find-part-by-type (cdr handle)
  50                                               "application/octet-stream"))
  51       (error "Corrupted pgp-encrypted part."))
  52     (with-temp-buffer
  53       (mm-insert-part child)
  54       (setq result (funcall mml2015-decrypt-function))
  55       (unless (car result)
  56         (error "Decrypting error."))
  57       (setq handles (mm-dissect-buffer t)))
  58     (mm-destroy-parts handle)
  59     (if (listp (car handles))
  60         handles
  61       (list handles))))
  62
  63 (defun mml2015-fix-micalg (alg)
  64   (upcase
  65    (if (and alg (string-match "^pgp-" alg))
  66        (substring alg (match-end 0))
  67      alg)))
  68
  69 ;;;###autoload
  70 (defun mml2015-verify (handle ctl)
  71   (let (part)
  72     (unless (setq part (mm-find-raw-part-by-type
  73                          ctl "application/pgp-signature" t))
  74       (error "Corrupted pgp-signature part."))
  75     (with-temp-buffer
  76       (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
  77       (insert (format "Hash: %s\n\n"
  78                       (or (mml2015-fix-micalg
  79                            (mail-content-type-get ctl 'micalg))
  80                           "SHA1")))
  81       (insert part "\n")
  82       (goto-char (point-max))
  83       (unless (setq part (mm-find-part-by-type
  84                            (cdr handle) "application/pgp-signature"))
  85         (error "Corrupted pgp-signature part."))
  86       (mm-insert-part part)
  87       (unless (funcall mml2015-verify-function)
  88         (error "Verify error.")))))
  89
  90 (eval-and-compile
  91   (autoload 'mc-encrypt-generic "mc-toplev")
  92   (autoload 'mc-cleanup-recipient-headers "mc-toplev")
  93   (autoload 'mc-sign-generic "mc-toplev"))
  94
  95 (eval-when-compile
  96   (defvar mc-default-scheme)
  97   (defvar mc-schemes))
  98
  99 (defun mml2015-mailcrypt-sign (cont)
 100   (mc-sign-generic (message-options-get 'message-sender)
 101                    nil nil nil nil)
 102   (let ((boundary
 103          (funcall mml-boundary-function (incf mml-multipart-number)))
 104         (scheme-alist (funcall (or mc-default-scheme
 105                                    (cdr (car mc-schemes)))))
 106         hash)
 107     (goto-char (point-min))
 108     (unless (re-search-forward (cdr (assq 'signed-begin-line scheme-alist)))
 109       (error "Cannot find signed begin line." ))
 110     (goto-char (match-beginning 0))
 111     (forward-line 1)
 112     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 113       (error "Cannot not find PGP hash." ))
 114     (setq hash (match-string 1))
 115     (unless (re-search-forward "^$" nil t)
 116       (error "Cannot not find PGP message." ))
 117     (forward-line 1)
 118     (delete-region (point-min) (point))
 119     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 120                     boundary))
 121     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 122                     (downcase hash)))
 123     (insert (format "\n--%s\n" boundary))
 124     (goto-char (point-max))
 125     (unless (re-search-backward (cdr (assq 'signed-end-line scheme-alist)))
 126       (error "Cannot find signature part." ))
 127     (goto-char (match-beginning 0))
 128     (unless (re-search-backward "^-+BEGIN" nil t)
 129       (error "Cannot find signature part." ))
 130     (goto-char (match-beginning 0))
 131     (insert (format "--%s\n" boundary))
 132     (insert "Content-Type: application/pgp-signature\n\n")
 133     (goto-char (point-max))
 134     (insert (format "--%s--\n" boundary))
 135     (goto-char (point-max))))
 136
 137 (defun mml2015-mailcrypt-encrypt (cont)
 138   (mc-encrypt-generic
 139    (or (message-options-get 'message-recipients)
 140        (message-options-set 'message-recipients
 141                             (mc-cleanup-recipient-headers
 142                              (read-string "Recipients: ")))))
 143   (let ((boundary
 144          (funcall mml-boundary-function (incf mml-multipart-number))))
 145     (goto-char (point-min))
 146     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 147                     boundary))
 148     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 149     (insert (format "--%s\n" boundary))
 150     (insert "Content-Type: application/pgp-encrypted\n\n")
 151     (insert "Version: 1\n\n")
 152     (insert (format "--%s\n" boundary))
 153     (insert "Content-Type: application/octet-stream\n\n")
 154     (goto-char (point-max))
 155     (insert (format "--%s--\n" boundary))
 156     (goto-char (point-max))))
 157
 158 ;;;###autoload
 159 (defun mml2015-encrypt (cont)
 160   (funcall mml2015-encrypt-function cont))
 161
 162 ;;;###autoload
 163 (defun mml2015-sign (cont)
 164   (funcall mml2015-sign-function cont))
 165
 166 ;;;###autoload
 167 (defun mml2015-setup ()
 168   )
 169
 170 (provide 'mml2015)
 171
 172 ;;; mml2015.el ends here