lisp/gnus/mml1991.el

   1 ;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007 Free Software Foundation, Inc.
   5
   6 ;; Author: Sascha Ldecke <sascha@meta-x.de>,
   7 ;;      Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
   8 ;; Keywords PGP
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Code:
  30
  31 (eval-when-compile
  32   (require 'cl)
  33   (require 'mm-util))
  34
  35 (require 'mml-sec)
  36
  37 (defvar mc-pgp-always-sign)
  38
  39 (autoload 'quoted-printable-decode-region "qp")
  40 (autoload 'quoted-printable-encode-region "qp")
  41
  42 (defvar mml1991-use mml2015-use
  43   "The package used for PGP.")
  44
  45 (defvar mml1991-function-alist
  46   '((mailcrypt mml1991-mailcrypt-sign
  47                mml1991-mailcrypt-encrypt)
  48     (gpg mml1991-gpg-sign
  49          mml1991-gpg-encrypt)
  50     (pgg mml1991-pgg-sign
  51          mml1991-pgg-encrypt)
  52     (epg mml1991-epg-sign
  53          mml1991-epg-encrypt))
  54   "Alist of PGP functions.")
  55
  56 (defvar mml1991-verbose mml-secure-verbose
  57   "If non-nil, ask the user about the current operation more verbosely.")
  58
  59 (defvar mml1991-cache-passphrase mml-secure-cache-passphrase
  60   "If t, cache passphrase.")
  61
  62 (defvar mml1991-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
  63   "How many seconds the passphrase is cached.
  64 Whether the passphrase is cached at all is controlled by
  65 `mml1991-cache-passphrase'.")
  66
  67 (defvar mml1991-signers nil
  68   "A list of your own key ID which will be used to sign a message.")
  69
  70 (defvar mml1991-encrypt-to-self nil
  71   "If t, add your own key ID to recipient list when encryption.")
  72
  73 ;;; mailcrypt wrapper
  74
  75 (eval-and-compile
  76   (autoload 'mc-sign-generic "mc-toplev"))
  77
  78 (defvar mml1991-decrypt-function 'mailcrypt-decrypt)
  79 (defvar mml1991-verify-function 'mailcrypt-verify)
  80
  81 (defun mml1991-mailcrypt-sign (cont)
  82   (let ((text (current-buffer))
  83         headers signature
  84         (result-buffer (get-buffer-create "*GPG Result*")))
  85     ;; Save MIME Content[^ ]+: headers from signing
  86     (goto-char (point-min))
  87     (while (looking-at "^Content[^ ]+:") (forward-line))
  88     (unless (bobp)
  89       (setq headers (buffer-string))
  90       (delete-region (point-min) (point)))
  91     (goto-char (point-max))
  92     (unless (bolp)
  93       (insert "\n"))
  94     (quoted-printable-decode-region (point-min) (point-max))
  95     (with-temp-buffer
  96       (setq signature (current-buffer))
  97       (insert-buffer-substring text)
  98       (unless (mc-sign-generic (message-options-get 'message-sender)
  99                                nil nil nil nil)
 100         (unless (> (point-max) (point-min))
 101           (pop-to-buffer result-buffer)
 102           (error "Sign error")))
 103       (goto-char (point-min))
 104       (while (re-search-forward "\r+$" nil t)
 105         (replace-match "" t t))
 106       (quoted-printable-encode-region (point-min) (point-max))
 107       (set-buffer text)
 108       (delete-region (point-min) (point-max))
 109       (if headers (insert headers))
 110       (insert "\n")
 111       (insert-buffer-substring signature)
 112       (goto-char (point-max)))))
 113
 114 (defun mml1991-mailcrypt-encrypt (cont &optional sign)
 115   (let ((text (current-buffer))
 116         (mc-pgp-always-sign
 117          (or mc-pgp-always-sign
 118              sign
 119              (eq t (or (message-options-get 'message-sign-encrypt)
 120                        (message-options-set
 121                         'message-sign-encrypt
 122                         (or (y-or-n-p "Sign the message? ")
 123                             'not))))
 124              'never))
 125         cipher
 126         (result-buffer (get-buffer-create "*GPG Result*")))
 127     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
 128     (goto-char (point-min))
 129     (while (looking-at "^Content[^ ]+:") (forward-line))
 130     (unless (bobp)
 131       (delete-region (point-min) (point)))
 132     (mm-with-unibyte-current-buffer
 133       (with-temp-buffer
 134         (setq cipher (current-buffer))
 135         (insert-buffer-substring text)
 136         (unless (mc-encrypt-generic
 137                  (or
 138                   (message-options-get 'message-recipients)
 139                   (message-options-set 'message-recipients
 140                                        (read-string "Recipients: ")))
 141                  nil
 142                  (point-min) (point-max)
 143                  (message-options-get 'message-sender)
 144                  'sign)
 145           (unless (> (point-max) (point-min))
 146             (pop-to-buffer result-buffer)
 147             (error "Encrypt error")))
 148         (goto-char (point-min))
 149         (while (re-search-forward "\r+$" nil t)
 150           (replace-match "" t t))
 151         (set-buffer text)
 152         (delete-region (point-min) (point-max))
 153         ;;(insert "Content-Type: application/pgp-encrypted\n\n")
 154         ;;(insert "Version: 1\n\n")
 155         (insert "\n")
 156         (insert-buffer-substring cipher)
 157         (goto-char (point-max))))))
 158
 159 ;;; gpg wrapper
 160
 161 (eval-and-compile
 162   (autoload 'gpg-sign-cleartext "gpg"))
 163
 164 (defun mml1991-gpg-sign (cont)
 165   (let ((text (current-buffer))
 166         headers signature
 167         (result-buffer (get-buffer-create "*GPG Result*")))
 168     ;; Save MIME Content[^ ]+: headers from signing
 169     (goto-char (point-min))
 170     (while (looking-at "^Content[^ ]+:") (forward-line))
 171     (unless (bobp)
 172       (setq headers (buffer-string))
 173       (delete-region (point-min) (point)))
 174     (goto-char (point-max))
 175     (unless (bolp)
 176       (insert "\n"))
 177     (quoted-printable-decode-region (point-min) (point-max))
 178     (with-temp-buffer
 179       (unless (gpg-sign-cleartext text (setq signature (current-buffer))
 180                                   result-buffer
 181                                   nil
 182                                   (message-options-get 'message-sender))
 183         (unless (> (point-max) (point-min))
 184           (pop-to-buffer result-buffer)
 185           (error "Sign error")))
 186       (goto-char (point-min))
 187       (while (re-search-forward "\r+$" nil t)
 188         (replace-match "" t t))
 189       (quoted-printable-encode-region (point-min) (point-max))
 190       (set-buffer text)
 191       (delete-region (point-min) (point-max))
 192       (if headers (insert headers))
 193       (insert "\n")
 194       (insert-buffer-substring signature)
 195       (goto-char (point-max)))))
 196
 197 (defun mml1991-gpg-encrypt (cont &optional sign)
 198   (let ((text (current-buffer))
 199         cipher
 200         (result-buffer (get-buffer-create "*GPG Result*")))
 201     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
 202     (goto-char (point-min))
 203     (while (looking-at "^Content[^ ]+:") (forward-line))
 204     (unless (bobp)
 205       (delete-region (point-min) (point)))
 206     (mm-with-unibyte-current-buffer
 207       (with-temp-buffer
 208         (flet ((gpg-encrypt-func
 209                 (sign plaintext ciphertext result recipients &optional
 210                       passphrase sign-with-key armor textmode)
 211                 (if sign
 212                     (gpg-sign-encrypt
 213                      plaintext ciphertext result recipients passphrase
 214                      sign-with-key armor textmode)
 215                   (gpg-encrypt
 216                    plaintext ciphertext result recipients passphrase
 217                    armor textmode))))
 218           (unless (gpg-encrypt-func
 219                    sign
 220                    text (setq cipher (current-buffer))
 221                    result-buffer
 222                    (split-string
 223                     (or
 224                      (message-options-get 'message-recipients)
 225                      (message-options-set 'message-recipients
 226                                           (read-string "Recipients: ")))
 227                     "[ \f\t\n\r\v,]+")
 228                    nil
 229                    (message-options-get 'message-sender)
 230                    t t) ; armor & textmode
 231             (unless (> (point-max) (point-min))
 232               (pop-to-buffer result-buffer)
 233               (error "Encrypt error"))))
 234         (goto-char (point-min))
 235         (while (re-search-forward "\r+$" nil t)
 236           (replace-match "" t t))
 237         (set-buffer text)
 238         (delete-region (point-min) (point-max))
 239         ;;(insert "Content-Type: application/pgp-encrypted\n\n")
 240         ;;(insert "Version: 1\n\n")
 241         (insert "\n")
 242         (insert-buffer-substring cipher)
 243         (goto-char (point-max))))))
 244
 245 ;; pgg wrapper
 246
 247 (defvar pgg-default-user-id)
 248 (defvar pgg-errors-buffer)
 249 (defvar pgg-output-buffer)
 250
 251 (defun mml1991-pgg-sign (cont)
 252   (let ((pgg-text-mode t)
 253         (pgg-default-user-id (or (message-options-get 'mml-sender)
 254                                  pgg-default-user-id))
 255         headers cte)
 256     ;; Don't sign headers.
 257     (goto-char (point-min))
 258     (when (re-search-forward "^$" nil t)
 259       (setq headers (buffer-substring (point-min) (point)))
 260       (save-restriction
 261         (narrow-to-region (point-min) (point))
 262         (setq cte (mail-fetch-field "content-transfer-encoding")))
 263       (forward-line 1)
 264       (delete-region (point-min) (point))
 265       (when cte
 266         (setq cte (intern (downcase cte)))
 267         (mm-decode-content-transfer-encoding cte)))
 268     (unless (pgg-sign-region (point-min) (point-max) t)
 269       (pop-to-buffer pgg-errors-buffer)
 270       (error "Encrypt error"))
 271     (delete-region (point-min) (point-max))
 272     (mm-with-unibyte-current-buffer
 273       (insert-buffer-substring pgg-output-buffer)
 274       (goto-char (point-min))
 275       (while (re-search-forward "\r+$" nil t)
 276         (replace-match "" t t))
 277       (when cte
 278         (mm-encode-content-transfer-encoding cte))
 279       (goto-char (point-min))
 280       (when headers
 281         (insert headers))
 282       (insert "\n"))
 283     t))
 284
 285 (defun mml1991-pgg-encrypt (cont &optional sign)
 286   (goto-char (point-min))
 287   (when (re-search-forward "^$" nil t)
 288     (let ((cte (save-restriction
 289                  (narrow-to-region (point-min) (point))
 290                  (mail-fetch-field "content-transfer-encoding"))))
 291       ;; Strip MIME headers since it will be ASCII armoured.
 292       (forward-line 1)
 293       (delete-region (point-min) (point))
 294       (when cte
 295         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 296   (unless (let ((pgg-text-mode t))
 297             (pgg-encrypt-region
 298              (point-min) (point-max)
 299              (split-string
 300               (or
 301                (message-options-get 'message-recipients)
 302                (message-options-set 'message-recipients
 303                                     (read-string "Recipients: ")))
 304               "[ \f\t\n\r\v,]+")
 305              sign))
 306     (pop-to-buffer pgg-errors-buffer)
 307     (error "Encrypt error"))
 308   (delete-region (point-min) (point-max))
 309   (insert "\n")
 310   (insert-buffer-substring pgg-output-buffer)
 311   t)
 312
 313 ;; epg wrapper
 314
 315 (defvar epg-user-id-alist)
 316 (defvar password-cache-expiry)
 317
 318 (eval-and-compile
 319   (autoload 'epg-make-context "epg")
 320   (autoload 'epg-passphrase-callback-function "epg")
 321   (autoload 'epa-select-keys "epa")
 322   (autoload 'epg-list-keys "epg")
 323   (autoload 'epg-context-set-armor "epg")
 324   (autoload 'epg-context-set-textmode "epg")
 325   (autoload 'epg-context-set-signers "epg")
 326   (autoload 'epg-context-set-passphrase-callback "epg")
 327   (autoload 'epg-sign-string "epg")
 328   (autoload 'epg-encrypt-string "epg")
 329   (autoload 'epg-configuration "epg-config")
 330   (autoload 'epg-expand-group "epg-config")
 331   (autoload 'password-read "password")
 332   (autoload 'password-cache-add "password")
 333   (autoload 'password-cache-remove "password"))
 334
 335 (defvar mml1991-epg-secret-key-id-list nil)
 336
 337 (defun mml1991-epg-passphrase-callback (context key-id ignore)
 338   (if (eq key-id 'SYM)
 339       (epg-passphrase-callback-function context key-id nil)
 340     (let* ((entry (assoc key-id epg-user-id-alist))
 341            (passphrase
 342             (password-read
 343              (format "GnuPG passphrase for %s: "
 344                      (if entry
 345                          (cdr entry)
 346                        key-id))
 347              (if (eq key-id 'PIN)
 348                  "PIN"
 349                key-id))))
 350       (when passphrase
 351         (let ((password-cache-expiry mml1991-passphrase-cache-expiry))
 352           (password-cache-add key-id passphrase))
 353         (setq mml1991-epg-secret-key-id-list
 354               (cons key-id mml1991-epg-secret-key-id-list))
 355         (copy-sequence passphrase)))))
 356
 357 (defun mml1991-epg-sign (cont)
 358   (let ((context (epg-make-context))
 359         headers cte signers signature)
 360     (if mml1991-verbose
 361         (setq signers (epa-select-keys context "Select keys for signing.
 362 If no one is selected, default secret key is used.  "
 363                                        mml1991-signers t))
 364       (if mml1991-signers
 365           (setq signers (mapcar (lambda (name)
 366                                   (car (epg-list-keys context name t)))
 367                                 mml1991-signers))))
 368     (epg-context-set-armor context t)
 369     (epg-context-set-textmode context t)
 370     (epg-context-set-signers context signers)
 371     (if mml1991-cache-passphrase
 372         (epg-context-set-passphrase-callback
 373          context
 374          #'mml1991-epg-passphrase-callback))
 375     ;; Don't sign headers.
 376     (goto-char (point-min))
 377     (when (re-search-forward "^$" nil t)
 378       (setq headers (buffer-substring (point-min) (point)))
 379       (save-restriction
 380         (narrow-to-region (point-min) (point))
 381         (setq cte (mail-fetch-field "content-transfer-encoding")))
 382       (forward-line 1)
 383       (delete-region (point-min) (point))
 384       (when cte
 385         (setq cte (intern (downcase cte)))
 386         (mm-decode-content-transfer-encoding cte)))
 387     (condition-case error
 388         (setq signature (epg-sign-string context (buffer-string) 'clear)
 389               mml1991-epg-secret-key-id-list nil)
 390       (error
 391        (while mml1991-epg-secret-key-id-list
 392          (password-cache-remove (car mml1991-epg-secret-key-id-list))
 393          (setq mml1991-epg-secret-key-id-list
 394                (cdr mml1991-epg-secret-key-id-list)))
 395        (signal (car error) (cdr error))))
 396     (delete-region (point-min) (point-max))
 397     (mm-with-unibyte-current-buffer
 398       (insert signature)
 399       (goto-char (point-min))
 400       (while (re-search-forward "\r+$" nil t)
 401         (replace-match "" t t))
 402       (when cte
 403         (mm-encode-content-transfer-encoding cte))
 404       (goto-char (point-min))
 405       (when headers
 406         (insert headers))
 407       (insert "\n"))
 408     t))
 409
 410 (defun mml1991-epg-encrypt (cont &optional sign)
 411   (goto-char (point-min))
 412   (when (re-search-forward "^$" nil t)
 413     (let ((cte (save-restriction
 414                  (narrow-to-region (point-min) (point))
 415                  (mail-fetch-field "content-transfer-encoding"))))
 416       ;; Strip MIME headers since it will be ASCII armoured.
 417       (forward-line 1)
 418       (delete-region (point-min) (point))
 419       (when cte
 420         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 421   (let ((context (epg-make-context))
 422         (recipients
 423          (if (message-options-get 'message-recipients)
 424              (split-string
 425               (message-options-get 'message-recipients)
 426               "[ \f\t\n\r\v,]+")))
 427         cipher signers config)
 428     ;; We should remove this check if epg-0.0.6 is released.
 429     (if (and (condition-case nil
 430                  (require 'epg-config)
 431                (error))
 432              (functionp #'epg-expand-group))
 433         (setq config (epg-configuration)
 434               recipients
 435               (apply #'nconc
 436                      (mapcar (lambda (recipient)
 437                                (or (epg-expand-group config recipient)
 438                                    (list recipient)))
 439                              recipients))))
 440     (if mml1991-verbose
 441         (setq recipients
 442               (epa-select-keys context "Select recipients for encryption.
 443 If no one is selected, symmetric encryption will be performed.  "
 444                                recipients))
 445       (setq recipients
 446             (delq nil (mapcar (lambda (name)
 447                                 (car (epg-list-keys context name)))
 448                               recipients))))
 449     (if mml1991-encrypt-to-self
 450         (if mml1991-signers
 451             (setq recipients
 452                   (nconc recipients
 453                          (mapcar (lambda (name)
 454                                    (car (epg-list-keys context name)))
 455                                  mml1991-signers)))
 456           (error "mml1991-signers not set")))
 457     (when sign
 458       (if mml1991-verbose
 459           (setq signers (epa-select-keys context "Select keys for signing.
 460 If no one is selected, default secret key is used.  "
 461                                          mml1991-signers t))
 462         (if mml1991-signers
 463             (setq signers (mapcar (lambda (name)
 464                                     (car (epg-list-keys context name t)))
 465                                   mml1991-signers))))
 466       (epg-context-set-signers context signers))
 467     (epg-context-set-armor context t)
 468     (epg-context-set-textmode context t)
 469     (if mml1991-cache-passphrase
 470         (epg-context-set-passphrase-callback
 471          context
 472          #'mml1991-epg-passphrase-callback))
 473     (condition-case error
 474         (setq cipher
 475               (epg-encrypt-string context (buffer-string) recipients sign)
 476               mml1991-epg-secret-key-id-list nil)
 477       (error
 478        (while mml1991-epg-secret-key-id-list
 479          (password-cache-remove (car mml1991-epg-secret-key-id-list))
 480          (setq mml1991-epg-secret-key-id-list
 481                (cdr mml1991-epg-secret-key-id-list)))
 482        (signal (car error) (cdr error))))
 483     (delete-region (point-min) (point-max))
 484     (insert "\n" cipher))
 485   t)
 486
 487 ;;;###autoload
 488 (defun mml1991-encrypt (cont &optional sign)
 489   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
 490     (if func
 491         (funcall func cont sign)
 492       (error "Cannot find encrypt function"))))
 493
 494 ;;;###autoload
 495 (defun mml1991-sign (cont)
 496   (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
 497     (if func
 498         (funcall func cont)
 499       (error "Cannot find sign function"))))
 500
 501 (provide 'mml1991)
 502
 503 ;; Local Variables:
 504 ;; coding: iso-8859-1
 505 ;; End:
 506
 507 ;;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706
 508 ;;; mml1991.el ends here