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

   1 ;;; mml-sec.el --- A package with security functions for MML documents
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007 Free Software Foundation, Inc.
   5
   6 ;; Author: Simon Josefsson <simon@josefsson.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 3, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (if (featurep 'xemacs)
  32     (or (load "password-cache" t)
  33         ;; Not all XEmacs versions support `noerror' arg of `require'.
  34         (require 'password))
  35   (or (require 'password-cache nil t)
  36       (require 'password)))
  37
  38 (autoload 'mml2015-sign "mml2015")
  39 (autoload 'mml2015-encrypt "mml2015")
  40 (autoload 'mml1991-sign "mml1991")
  41 (autoload 'mml1991-encrypt "mml1991")
  42 (autoload 'message-goto-body "message")
  43 (autoload 'mml-insert-tag "mml")
  44 (autoload 'mml-smime-sign "mml-smime")
  45 (autoload 'mml-smime-encrypt "mml-smime")
  46 (autoload 'mml-smime-sign-query "mml-smime")
  47 (autoload 'mml-smime-encrypt-query "mml-smime")
  48 (autoload 'mml-smime-verify "mml-smime")
  49 (autoload 'mml-smime-verify-test "mml-smime")
  50
  51 (defvar mml-sign-alist
  52   '(("smime"     mml-smime-sign-buffer     mml-smime-sign-query)
  53     ("pgp"       mml-pgp-sign-buffer       list)
  54     ("pgpauto"   mml-pgpauto-sign-buffer  list)
  55     ("pgpmime"   mml-pgpmime-sign-buffer   list))
  56   "Alist of MIME signer functions.")
  57
  58 (defcustom mml-default-sign-method "pgpmime"
  59   "Default sign method.
  60 The string must have an entry in `mml-sign-alist'."
  61   :version "22.1"
  62   :type '(choice (const "smime")
  63                  (const "pgp")
  64                  (const "pgpauto")
  65                  (const "pgpmime")
  66                  string)
  67   :group 'message)
  68
  69 (defvar mml-encrypt-alist
  70   '(("smime"     mml-smime-encrypt-buffer     mml-smime-encrypt-query)
  71     ("pgp"       mml-pgp-encrypt-buffer       list)
  72     ("pgpauto"   mml-pgpauto-sign-buffer  list)
  73     ("pgpmime"   mml-pgpmime-encrypt-buffer   list))
  74   "Alist of MIME encryption functions.")
  75
  76 (defcustom mml-default-encrypt-method "pgpmime"
  77   "Default encryption method.
  78 The string must have an entry in `mml-encrypt-alist'."
  79   :version "22.1"
  80   :type '(choice (const "smime")
  81                  (const "pgp")
  82                  (const "pgpauto")
  83                  (const "pgpmime")
  84                  string)
  85   :group 'message)
  86
  87 (defcustom mml-signencrypt-style-alist
  88   '(("smime"   separate)
  89     ("pgp"     combined)
  90     ("pgpauto" combined)
  91     ("pgpmime" combined))
  92   "Alist specifying if `signencrypt' results in two separate operations or not.
  93 The first entry indicates the MML security type, valid entries include
  94 the strings \"smime\", \"pgp\", and \"pgpmime\".  The second entry is
  95 a symbol `separate' or `combined' where `separate' means that MML signs
  96 and encrypt messages in a two step process, and `combined' means that MML
  97 signs and encrypt the message in one step.
  98
  99 Note that the output generated by using a `combined' mode is NOT
 100 understood by all PGP implementations, in particular PGP version
 101 2 does not support it!  See Info node `(message)Security' for
 102 details."
 103   :version "22.1"
 104   :group 'message
 105   :type '(repeat (list (choice (const :tag "S/MIME" "smime")
 106                                (const :tag "PGP" "pgp")
 107                                (const :tag "PGP/MIME" "pgpmime")
 108                                (string :tag "User defined"))
 109                        (choice (const :tag "Separate" separate)
 110                                (const :tag "Combined" combined)))))
 111
 112 (defcustom mml-secure-verbose nil
 113   "If non-nil, ask the user about the current operation more verbosely."
 114   :group 'message
 115   :type 'boolean)
 116
 117 (defcustom mml-secure-cache-passphrase password-cache
 118   "If t, cache passphrase."
 119   :group 'message
 120   :type 'boolean)
 121
 122 (defcustom mml-secure-passphrase-cache-expiry password-cache-expiry
 123   "How many seconds the passphrase is cached.
 124 Whether the passphrase is cached at all is controlled by
 125 `mml-secure-cache-passphrase'."
 126   :group 'message
 127   :type 'integer)
 128
 129 ;;; Configuration/helper functions
 130
 131 (defun mml-signencrypt-style (method &optional style)
 132   "Function for setting/getting the signencrypt-style used.  Takes two
 133 arguments, the method (e.g. \"pgp\") and optionally the mode
 134 \(e.g. combined).  If the mode is omitted, the current value is returned.
 135
 136 For example, if you prefer to use combined sign & encrypt with
 137 smime, putting the following in your Gnus startup file will
 138 enable that behavior:
 139
 140 \(mml-set-signencrypt-style \"smime\" combined)
 141
 142 You can also customize or set `mml-signencrypt-style-alist' instead."
 143   (let ((style-item (assoc method mml-signencrypt-style-alist)))
 144     (if style-item
 145         (if (or (eq style 'separate)
 146                 (eq style 'combined))
 147             ;; valid style setting?
 148             (setf (second style-item) style)
 149           ;; otherwise, just return the current value
 150           (second style-item))
 151       (message "Warning, attempt to set invalid signencrypt style"))))
 152
 153 ;;; Security functions
 154
 155 (defun mml-smime-sign-buffer (cont)
 156   (or (mml-smime-sign cont)
 157       (error "Signing failed... inspect message logs for errors")))
 158
 159 (defun mml-smime-encrypt-buffer (cont &optional sign)
 160   (when sign
 161     (message "Combined sign and encrypt S/MIME not support yet")
 162     (sit-for 1))
 163   (or (mml-smime-encrypt cont)
 164       (error "Encryption failed... inspect message logs for errors")))
 165
 166 (defun mml-pgp-sign-buffer (cont)
 167   (or (mml1991-sign cont)
 168       (error "Signing failed... inspect message logs for errors")))
 169
 170 (defun mml-pgp-encrypt-buffer (cont &optional sign)
 171   (or (mml1991-encrypt cont sign)
 172       (error "Encryption failed... inspect message logs for errors")))
 173
 174 (defun mml-pgpmime-sign-buffer (cont)
 175   (or (mml2015-sign cont)
 176       (error "Signing failed... inspect message logs for errors")))
 177
 178 (defun mml-pgpmime-encrypt-buffer (cont &optional sign)
 179   (or (mml2015-encrypt cont sign)
 180       (error "Encryption failed... inspect message logs for errors")))
 181
 182 (defun mml-pgpauto-sign-buffer (cont)
 183   (message-goto-body)
 184   (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
 185           (mml2015-sign cont)
 186         (mml1991-sign cont))
 187       (error "Encryption failed... inspect message logs for errors")))
 188
 189 (defun mml-pgpauto-encrypt-buffer (cont &optional sign)
 190   (message-goto-body)
 191   (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
 192           (mml2015-encrypt cont sign)
 193         (mml1991-encrypt cont sign))
 194       (error "Encryption failed... inspect message logs for errors")))
 195
 196 (defun mml-secure-part (method &optional sign)
 197   (save-excursion
 198     (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist
 199                                                 mml-encrypt-alist))))))
 200       (cond ((re-search-backward
 201               "<#\\(multipart\\|part\\|external\\|mml\\)" nil t)
 202              (goto-char (match-end 0))
 203              (insert (if sign " sign=" " encrypt=") method)
 204              (while tags
 205                (let ((key (pop tags))
 206                      (value (pop tags)))
 207                  (when value
 208                    ;; Quote VALUE if it contains suspicious characters.
 209                    (when (string-match "[\"'\\~/*;() \t\n]" value)
 210                      (setq value (prin1-to-string value)))
 211                    (insert (format " %s=%s" key value))))))
 212             ((or (re-search-backward
 213                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 214                  (re-search-forward
 215                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
 216              (goto-char (match-end 0))
 217              (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
 218                                                 (cons method tags))))
 219             (t (error "The message is corrupted. No mail header separator"))))))
 220
 221 (defvar mml-secure-method
 222   (if (equal mml-default-encrypt-method mml-default-sign-method)
 223       mml-default-sign-method
 224     "pgpmime")
 225   "Current security method.  Internal variable.")
 226
 227 (defun mml-secure-sign (&optional method)
 228   "Add MML tags to sign this MML part.
 229 Use METHOD if given.  Else use `mml-secure-method' or
 230 `mml-default-sign-method'."
 231   (interactive)
 232   (mml-secure-part
 233    (or method mml-secure-method mml-default-sign-method)
 234    'sign))
 235
 236 (defun mml-secure-encrypt (&optional method)
 237   "Add MML tags to encrypt this MML part.
 238 Use METHOD if given.  Else use `mml-secure-method' or
 239 `mml-default-sign-method'."
 240   (interactive)
 241   (mml-secure-part
 242    (or method mml-secure-method mml-default-sign-method)))
 243
 244 (defun mml-secure-sign-pgp ()
 245   "Add MML tags to PGP sign this MML part."
 246   (interactive)
 247   (mml-secure-part "pgp" 'sign))
 248
 249 (defun mml-secure-sign-pgpauto ()
 250   "Add MML tags to PGP-auto sign this MML part."
 251   (interactive)
 252   (mml-secure-part "pgpauto" 'sign))
 253
 254 (defun mml-secure-sign-pgpmime ()
 255   "Add MML tags to PGP/MIME sign this MML part."
 256   (interactive)
 257   (mml-secure-part "pgpmime" 'sign))
 258
 259 (defun mml-secure-sign-smime ()
 260   "Add MML tags to S/MIME sign this MML part."
 261   (interactive)
 262   (mml-secure-part "smime" 'sign))
 263
 264 (defun mml-secure-encrypt-pgp ()
 265   "Add MML tags to PGP encrypt this MML part."
 266   (interactive)
 267   (mml-secure-part "pgp"))
 268
 269 (defun mml-secure-encrypt-pgpmime ()
 270   "Add MML tags to PGP/MIME encrypt this MML part."
 271   (interactive)
 272   (mml-secure-part "pgpmime"))
 273
 274 (defun mml-secure-encrypt-smime ()
 275   "Add MML tags to S/MIME encrypt this MML part."
 276   (interactive)
 277   (mml-secure-part "smime"))
 278
 279 ;; defuns that add the proper <#secure ...> tag to the top of the message body
 280 (defun mml-secure-message (method &optional modesym)
 281   (let ((mode (prin1-to-string modesym))
 282         (tags (append
 283                (if (or (eq modesym 'sign)
 284                        (eq modesym 'signencrypt))
 285                    (funcall (nth 2 (assoc method mml-sign-alist))))
 286                (if (or (eq modesym 'encrypt)
 287                        (eq modesym 'signencrypt))
 288                    (funcall (nth 2 (assoc method mml-encrypt-alist))))))
 289         insert-loc)
 290     (mml-unsecure-message)
 291     (save-excursion
 292       (goto-char (point-min))
 293       (cond ((re-search-forward
 294               (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 295              (goto-char (setq insert-loc (match-end 0)))
 296              (unless (looking-at "<#secure")
 297                (apply 'mml-insert-tag
 298                 'secure 'method method 'mode mode tags)))
 299             (t (error
 300                 "The message is corrupted. No mail header separator"))))
 301     (when (eql insert-loc (point))
 302       (forward-line 1))))
 303
 304 (defun mml-unsecure-message ()
 305   "Remove security related MML tags from message."
 306   (interactive)
 307   (save-excursion
 308     (goto-char (point-max))
 309     (when (re-search-backward "^<#secure.*>\n" nil t)
 310       (delete-region (match-beginning 0) (match-end 0)))))
 311
 312
 313 (defun mml-secure-message-sign (&optional method)
 314   "Add MML tags to sign this MML part.
 315 Use METHOD if given. Else use `mml-secure-method' or
 316 `mml-default-sign-method'."
 317   (interactive)
 318   (mml-secure-part
 319    (or method mml-secure-method mml-default-sign-method)
 320    'sign))
 321
 322 (defun mml-secure-message-sign-encrypt (&optional method)
 323   "Add MML tag to sign and encrypt the entire message.
 324 Use METHOD if given. Else use `mml-secure-method' or
 325 `mml-default-sign-method'."
 326   (interactive)
 327   (mml-secure-message
 328    (or method mml-secure-method mml-default-sign-method)
 329    'signencrypt))
 330
 331 (defun mml-secure-message-encrypt (&optional method)
 332   "Add MML tag to encrypt the entire message.
 333 Use METHOD if given. Else use `mml-secure-method' or
 334 `mml-default-sign-method'."
 335   (interactive)
 336   (mml-secure-message
 337    (or method mml-secure-method mml-default-sign-method)
 338    'encrypt))
 339
 340 (defun mml-secure-message-sign-smime ()
 341   "Add MML tag to encrypt/sign the entire message."
 342   (interactive)
 343   (mml-secure-message "smime" 'sign))
 344
 345 (defun mml-secure-message-sign-pgp ()
 346   "Add MML tag to encrypt/sign the entire message."
 347   (interactive)
 348   (mml-secure-message "pgp" 'sign))
 349
 350 (defun mml-secure-message-sign-pgpmime ()
 351   "Add MML tag to encrypt/sign the entire message."
 352   (interactive)
 353   (mml-secure-message "pgpmime" 'sign))
 354
 355 (defun mml-secure-message-sign-pgpauto ()
 356   "Add MML tag to encrypt/sign the entire message."
 357   (interactive)
 358   (mml-secure-message "pgpauto" 'sign))
 359
 360 (defun mml-secure-message-encrypt-smime (&optional dontsign)
 361   "Add MML tag to encrypt and sign the entire message.
 362 If called with a prefix argument, only encrypt (do NOT sign)."
 363   (interactive "P")
 364   (mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt)))
 365
 366 (defun mml-secure-message-encrypt-pgp (&optional dontsign)
 367   "Add MML tag to encrypt and sign the entire message.
 368 If called with a prefix argument, only encrypt (do NOT sign)."
 369   (interactive "P")
 370   (mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt)))
 371
 372 (defun mml-secure-message-encrypt-pgpmime (&optional dontsign)
 373   "Add MML tag to encrypt and sign the entire message.
 374 If called with a prefix argument, only encrypt (do NOT sign)."
 375   (interactive "P")
 376   (mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt)))
 377
 378 (defun mml-secure-message-encrypt-pgpauto (&optional dontsign)
 379   "Add MML tag to encrypt and sign the entire message.
 380 If called with a prefix argument, only encrypt (do NOT sign)."
 381   (interactive "P")
 382   (mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt)))
 383
 384 (provide 'mml-sec)
 385
 386 ;;; arch-tag: 111c56e7-df5e-4287-87d7-93ed2911ec6c
 387 ;;; mml-sec.el ends here