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