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