cgit.sxemacs.org Git - gnus/blob - lisp/mml-sec.el

   1 ;;; mml-sec.el --- A package with security functions for MML documents
   2 ;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
   3
   4 ;; Author: Simon Josefsson <simon@josefsson.org>
   5 ;; This file is not part of GNU Emacs, but the same permissions apply.
   6
   7 ;; GNU Emacs is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (require 'mml2015)
  27 (require 'mml1991)
  28 (require 'mml-smime)
  29 (eval-when-compile (require 'cl))
  30
  31 (defvar mml-sign-alist
  32   '(("smime"     mml-smime-sign-buffer     mml-smime-sign-query)
  33     ("pgp"       mml-pgp-sign-buffer       list)
  34     ("pgpmime"   mml-pgpmime-sign-buffer   list))
  35   "Alist of MIME signer functions.")
  36
  37 (defvar mml-default-sign-method (caar mml-sign-alist)
  38   "Default sign method.")
  39
  40 (defvar mml-encrypt-alist
  41   '(("smime"     mml-smime-encrypt-buffer     mml-smime-encrypt-query)
  42     ("pgp"       mml-pgp-encrypt-buffer       list)
  43     ("pgpmime"   mml-pgpmime-encrypt-buffer   list))
  44   "Alist of MIME encryption functions.")
  45
  46 (defvar mml-default-encrypt-method (caar mml-encrypt-alist)
  47   "Default encryption method.")
  48
  49 (defvar mml-signencrypt-style
  50   '(("smime"   separate)
  51     ("pgp"     separate)
  52     ("pgpmime" combined))
  53   "Alist specifying whether or not a single sign & encrypt
  54 operation should be perfomed when requesting signencrypt.")
  55
  56 ;;; Security functions
  57
  58 (defun mml-smime-sign-buffer (cont)
  59   (or (mml-smime-sign cont)
  60       (error "Signing failed... inspect message logs for errors")))
  61
  62 (defun mml-smime-encrypt-buffer (cont)
  63   (or (mml-smime-encrypt cont)
  64       (error "Encryption failed... inspect message logs for errors")))
  65
  66 (defun mml-pgp-sign-buffer (cont)
  67   (or (mml1991-sign cont)
  68       (error "Signing failed... inspect message logs for errors")))
  69
  70 (defun mml-pgp-encrypt-buffer (cont)
  71   (or (mml1991-encrypt cont)
  72       (error "Encryption failed... inspect message logs for errors")))
  73
  74 (defun mml-pgpmime-sign-buffer (cont)
  75   (or (mml2015-sign cont)
  76       (error "Signing failed... inspect message logs for errors")))
  77
  78 (defun mml-pgpmime-encrypt-buffer (cont &optional sign)
  79   (or (mml2015-encrypt cont sign)
  80       (error "Encryption failed... inspect message logs for errors")))
  81
  82 (defun mml-secure-part (method &optional sign)
  83   (save-excursion
  84     (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist
  85                                                 mml-encrypt-alist))))))
  86       (cond ((re-search-backward
  87               "<#\\(multipart\\|part\\|external\\|mml\\)" nil t)
  88              (goto-char (match-end 0))
  89              (insert (if sign " sign=" " encrypt=") method)
  90              (while tags
  91                (let ((key (pop tags))
  92                      (value (pop tags)))
  93                  (when value
  94                    ;; Quote VALUE if it contains suspicious characters.
  95                    (when (string-match "[\"'\\~/*;() \t\n]" value)
  96                      (setq value (prin1-to-string value)))
  97                    (insert (format " %s=%s" key value))))))
  98             ((or (re-search-backward
  99                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 100                  (re-search-forward
 101                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
 102              (goto-char (match-end 0))
 103              (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
 104                                                 (cons method tags))))
 105             (t (error "The message is corrupted. No mail header separator"))))))
 106
 107 (defun mml-secure-sign-pgp ()
 108   "Add MML tags to PGP sign this MML part."
 109   (interactive)
 110   (mml-secure-part "pgp" 'sign))
 111
 112 (defun mml-secure-sign-pgpmime ()
 113   "Add MML tags to PGP/MIME sign this MML part."
 114   (interactive)
 115   (mml-secure-part "pgpmime" 'sign))
 116
 117 (defun mml-secure-sign-smime ()
 118   "Add MML tags to S/MIME sign this MML part."
 119   (interactive)
 120   (mml-secure-part "smime" 'sign))
 121
 122 (defun mml-secure-encrypt-pgp ()
 123   "Add MML tags to PGP encrypt this MML part."
 124   (interactive)
 125   (mml-secure-part "pgp"))
 126
 127 (defun mml-secure-encrypt-pgpmime ()
 128   "Add MML tags to PGP/MIME encrypt this MML part."
 129   (interactive)
 130   (mml-secure-part "pgpmime"))
 131
 132 (defun mml-secure-encrypt-smime ()
 133   "Add MML tags to S/MIME encrypt this MML part."
 134   (interactive)
 135   (mml-secure-part "smime"))
 136
 137 ;; defuns that add the proper <#secure ...> tag to the top of the message body
 138 (defun mml-secure-message (method &optional modesym)
 139   (let ((mode (prin1-to-string modesym))
 140         insert-loc)
 141     (mml-unsecure-message)
 142     (save-excursion
 143       (goto-char (point-min))
 144       (cond ((re-search-forward
 145               (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 146              (goto-char (setq insert-loc (match-end 0)))
 147              (unless (looking-at "<#secure")
 148                (mml-insert-tag
 149                 'secure 'method method 'mode mode)))
 150             (t (error
 151                 "The message is corrupted. No mail header separator"))))
 152     (when (eql insert-loc (point))
 153       (forward-line 1))))
 154
 155 (defun mml-unsecure-message ()
 156   "Remove security related MML tags from message."
 157   (interactive)
 158   (save-excursion
 159     (goto-char (point-max))
 160     (when (re-search-backward "^<#secure.*>\n" nil t)
 161       (kill-region (match-beginning 0) (match-end 0)))))
 162
 163 (defun mml-secure-message-sign-smime ()
 164   "Add MML tag to encrypt/sign the entire message."
 165   (interactive)
 166   (mml-secure-message "smime" 'sign))
 167
 168 (defun mml-secure-message-sign-pgp ()
 169   "Add MML tag to encrypt/sign the entire message."
 170   (interactive)
 171   (mml-secure-message "pgp" 'sign))
 172
 173 (defun mml-secure-message-sign-pgpmime ()
 174   "Add MML tag to encrypt/sign the entire message."
 175   (interactive)
 176   (mml-secure-message "pgpmime" 'sign))
 177
 178 (defun mml-secure-message-encrypt-smime (&optional dontsign)
 179   "Add MML tag to encrypt and sign the entire message.
 180 If called with a prefix argument, only encrypt (do NOT sign)."
 181   (interactive "P")
 182   (mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt)))
 183
 184 (defun mml-secure-message-encrypt-pgp (&optional dontsign)
 185   "Add MML tag to encrypt and sign the entire message.
 186 If called with a prefix argument, only encrypt (do NOT sign)."
 187   (interactive "P")
 188   (mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt)))
 189
 190 (defun mml-secure-message-encrypt-pgpmime (&optional dontsign)
 191   "Add MML tag to encrypt and sign the entire message.
 192 If called with a prefix argument, only encrypt (do NOT sign)."
 193   (interactive "P")
 194   (mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt)))
 195
 196 (provide 'mml-sec)
 197
 198 ;;; mml-sec.el ends here