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     ("pgpauto"   mml-pgpauto-sign-buffer  list)
  35     ("pgpmime"   mml-pgpmime-sign-buffer   list))
  36   "Alist of MIME signer functions.")
  37
  38 (defvar mml-default-sign-method (caar mml-sign-alist)
  39   "Default sign method.")
  40
  41 (defvar mml-encrypt-alist
  42   '(("smime"     mml-smime-encrypt-buffer     mml-smime-encrypt-query)
  43     ("pgp"       mml-pgp-encrypt-buffer       list)
  44     ("pgpauto"   mml-pgpauto-sign-buffer  list)
  45     ("pgpmime"   mml-pgpmime-encrypt-buffer   list))
  46   "Alist of MIME encryption functions.")
  47
  48 (defvar mml-default-encrypt-method (caar mml-encrypt-alist)
  49   "Default encryption method.")
  50
  51 (defcustom mml-signencrypt-style-alist
  52   '(("smime"   separate)
  53     ("pgp"     separate)
  54     ("pgpauto" separate)
  55     ("pgpmime" separate))
  56   "Alist specifying if `signencrypt' results in two separate operations or not.
  57 The first entry indicates the MML security type, valid entries include
  58 the strings \"smime\", \"pgp\", and \"pgpmime\".  The second entry is
  59 a symbol `separate' or `combined' where `separate' means that MML signs
  60 and encrypt messages in a two step process, and `combined' means that MML
  61 signs and encrypt the message in one step.
  62 Note that the `combined' mode is NOT supported by all OpenPGP implementations,
  63 in particular PGP version 2 does not support it!"
  64   :type '(repeat (list (choice (const :tag "S/MIME" "smime")
  65                                (const :tag "PGP" "pgp")
  66                                (const :tag "PGP/MIME" "pgpmime")
  67                                (string :tag "User defined"))
  68                        (choice (const :tag "Separate" separate)
  69                                (const :tag "Combined" combined)))))
  70
  71 ;;; Configuration/helper functions
  72
  73 (defun mml-signencrypt-style (method &optional style)
  74   "Function for setting/getting the signencrypt-style used.  Takes two
  75 arguments, the method (e.g. \"pgp\") and optionally the mode
  76 \(e.g. combined).  If the mode is omitted, the current value is returned.
  77
  78 For example, if you prefer to use combined sign & encrypt with
  79 smime, putting the following in your Gnus startup file will
  80 enable that behavior:
  81
  82 \(mml-set-signencrypt-style \"smime\" combined)
  83
  84 You can also customize or set `mml-signencrypt-style-alist' instead."
  85   (let ((style-item (assoc method mml-signencrypt-style-alist)))
  86     (if style-item
  87         (if (or (eq style 'separate)
  88                 (eq style 'combined))
  89             ;; valid style setting?
  90             (setf (second style-item) style)
  91           ;; otherwise, just return the current value
  92           (second style-item))
  93       (gnus-message 3 "Warning, attempt to set invalid signencrypt-style"))))
  94
  95 ;;; Security functions
  96
  97 (defun mml-smime-sign-buffer (cont)
  98   (or (mml-smime-sign cont)
  99       (error "Signing failed... inspect message logs for errors")))
 100
 101 (defun mml-smime-encrypt-buffer (cont &optional sign)
 102   (when sign
 103     (message "Combined sign and encrypt S/MIME not support yet")
 104     (sit-for 1))
 105   (or (mml-smime-encrypt cont)
 106       (error "Encryption failed... inspect message logs for errors")))
 107
 108 (defun mml-pgp-sign-buffer (cont)
 109   (or (mml1991-sign cont)
 110       (error "Signing failed... inspect message logs for errors")))
 111
 112 (defun mml-pgp-encrypt-buffer (cont &optional sign)
 113   (or (mml1991-encrypt cont sign)
 114       (error "Encryption failed... inspect message logs for errors")))
 115
 116 (defun mml-pgpmime-sign-buffer (cont)
 117   (or (mml2015-sign cont)
 118       (error "Signing failed... inspect message logs for errors")))
 119
 120 (defun mml-pgpmime-encrypt-buffer (cont &optional sign)
 121   (or (mml2015-encrypt cont sign)
 122       (error "Encryption failed... inspect message logs for errors")))
 123
 124 (defun mml-pgpauto-sign-buffer (cont)
 125   (message-goto-body)
 126   (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
 127           (mml2015-sign cont)
 128         (mml1991-sign cont))
 129       (error "Encryption failed... inspect message logs for errors")))
 130
 131 (defun mml-pgpauto-encrypt-buffer (cont &optional sign)
 132   (message-goto-body)
 133   (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
 134           (mml2015-encrypt cont sign)
 135         (mml1991-encrypt cont sign))
 136       (error "Encryption failed... inspect message logs for errors")))
 137
 138 (defun mml-secure-part (method &optional sign)
 139   (save-excursion
 140     (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist
 141                                                 mml-encrypt-alist))))))
 142       (cond ((re-search-backward
 143               "<#\\(multipart\\|part\\|external\\|mml\\)" nil t)
 144              (goto-char (match-end 0))
 145              (insert (if sign " sign=" " encrypt=") method)
 146              (while tags
 147                (let ((key (pop tags))
 148                      (value (pop tags)))
 149                  (when value
 150                    ;; Quote VALUE if it contains suspicious characters.
 151                    (when (string-match "[\"'\\~/*;() \t\n]" value)
 152                      (setq value (prin1-to-string value)))
 153                    (insert (format " %s=%s" key value))))))
 154             ((or (re-search-backward
 155                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 156                  (re-search-forward
 157                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
 158              (goto-char (match-end 0))
 159              (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
 160                                                 (cons method tags))))
 161             (t (error "The message is corrupted. No mail header separator"))))))
 162
 163 (defun mml-secure-sign-pgp ()
 164   "Add MML tags to PGP sign this MML part."
 165   (interactive)
 166   (mml-secure-part "pgp" 'sign))
 167
 168 (defun mml-secure-sign-pgpauto ()
 169   "Add MML tags to PGP-auto sign this MML part."
 170   (interactive)
 171   (mml-secure-part "pgpauto" 'sign))
 172
 173 (defun mml-secure-sign-pgpmime ()
 174   "Add MML tags to PGP/MIME sign this MML part."
 175   (interactive)
 176   (mml-secure-part "pgpmime" 'sign))
 177
 178 (defun mml-secure-sign-smime ()
 179   "Add MML tags to S/MIME sign this MML part."
 180   (interactive)
 181   (mml-secure-part "smime" 'sign))
 182
 183 (defun mml-secure-encrypt-pgp ()
 184   "Add MML tags to PGP encrypt this MML part."
 185   (interactive)
 186   (mml-secure-part "pgp"))
 187
 188 (defun mml-secure-encrypt-pgpmime ()
 189   "Add MML tags to PGP/MIME encrypt this MML part."
 190   (interactive)
 191   (mml-secure-part "pgpmime"))
 192
 193 (defun mml-secure-encrypt-smime ()
 194   "Add MML tags to S/MIME encrypt this MML part."
 195   (interactive)
 196   (mml-secure-part "smime"))
 197
 198 ;; defuns that add the proper <#secure ...> tag to the top of the message body
 199 (defun mml-secure-message (method &optional modesym)
 200   (let ((mode (prin1-to-string modesym))
 201         insert-loc)
 202     (mml-unsecure-message)
 203     (save-excursion
 204       (goto-char (point-min))
 205       (cond ((re-search-forward
 206               (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 207              (goto-char (setq insert-loc (match-end 0)))
 208              (unless (looking-at "<#secure")
 209                (mml-insert-tag
 210                 'secure 'method method 'mode mode)))
 211             (t (error
 212                 "The message is corrupted. No mail header separator"))))
 213     (when (eql insert-loc (point))
 214       (forward-line 1))))
 215
 216 (defun mml-unsecure-message ()
 217   "Remove security related MML tags from message."
 218   (interactive)
 219   (save-excursion
 220     (goto-char (point-max))
 221     (when (re-search-backward "^<#secure.*>\n" nil t)
 222       (kill-region (match-beginning 0) (match-end 0)))))
 223
 224 (defun mml-secure-message-sign-smime ()
 225   "Add MML tag to encrypt/sign the entire message."
 226   (interactive)
 227   (mml-secure-message "smime" 'sign))
 228
 229 (defun mml-secure-message-sign-pgp ()
 230   "Add MML tag to encrypt/sign the entire message."
 231   (interactive)
 232   (mml-secure-message "pgp" 'sign))
 233
 234 (defun mml-secure-message-sign-pgpmime ()
 235   "Add MML tag to encrypt/sign the entire message."
 236   (interactive)
 237   (mml-secure-message "pgpmime" 'sign))
 238
 239 (defun mml-secure-message-sign-pgpauto ()
 240   "Add MML tag to encrypt/sign the entire message."
 241   (interactive)
 242   (mml-secure-message "pgpauto" 'sign))
 243
 244 (defun mml-secure-message-encrypt-smime (&optional dontsign)
 245   "Add MML tag to encrypt and sign the entire message.
 246 If called with a prefix argument, only encrypt (do NOT sign)."
 247   (interactive "P")
 248   (mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt)))
 249
 250 (defun mml-secure-message-encrypt-pgp (&optional dontsign)
 251   "Add MML tag to encrypt and sign the entire message.
 252 If called with a prefix argument, only encrypt (do NOT sign)."
 253   (interactive "P")
 254   (mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt)))
 255
 256 (defun mml-secure-message-encrypt-pgpmime (&optional dontsign)
 257   "Add MML tag to encrypt and sign the entire message.
 258 If called with a prefix argument, only encrypt (do NOT sign)."
 259   (interactive "P")
 260   (mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt)))
 261
 262 (defun mml-secure-message-encrypt-pgpauto (&optional dontsign)
 263   "Add MML tag to encrypt and sign the entire message.
 264 If called with a prefix argument, only encrypt (do NOT sign)."
 265   (interactive "P")
 266   (mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt)))
 267
 268 (provide 'mml-sec)
 269
 270 ;;; mml-sec.el ends here