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