cgit.sxemacs.org Git - gnus/blob - lisp/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 Free Software Foundation, Inc.
   5
   6 ;; Author: Sascha Lüdecke <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 2, 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 (eval-when-compile
 248   (defvar pgg-default-user-id)
 249   (defvar pgg-errors-buffer)
 250   (defvar pgg-output-buffer))
 251
 252 (defun mml1991-pgg-sign (cont)
 253   (let ((pgg-text-mode t)
 254         (pgg-default-user-id (or (message-options-get 'mml-sender)
 255                                  pgg-default-user-id))
 256         headers cte)
 257     ;; Don't sign headers.
 258     (goto-char (point-min))
 259     (when (re-search-forward "^$" nil t)
 260       (setq headers (buffer-substring (point-min) (point)))
 261       (save-restriction
 262         (narrow-to-region (point-min) (point))
 263         (setq cte (mail-fetch-field "content-transfer-encoding")))
 264       (forward-line 1)
 265       (delete-region (point-min) (point))
 266       (when cte
 267         (setq cte (intern (downcase cte)))
 268         (mm-decode-content-transfer-encoding cte)))
 269     (unless (pgg-sign-region (point-min) (point-max) t)
 270       (pop-to-buffer pgg-errors-buffer)
 271       (error "Encrypt error"))
 272     (delete-region (point-min) (point-max))
 273     (mm-with-unibyte-current-buffer
 274       (insert-buffer-substring pgg-output-buffer)
 275       (goto-char (point-min))
 276       (while (re-search-forward "\r+$" nil t)
 277         (replace-match "" t t))
 278       (when cte
 279         (mm-encode-content-transfer-encoding cte))
 280       (goto-char (point-min))
 281       (when headers
 282         (insert headers))
 283       (insert "\n"))
 284     t))
 285
 286 (defun mml1991-pgg-encrypt (cont &optional sign)
 287   (goto-char (point-min))
 288   (when (re-search-forward "^$" nil t)
 289     (let ((cte (save-restriction
 290                  (narrow-to-region (point-min) (point))
 291                  (mail-fetch-field "content-transfer-encoding"))))
 292       ;; Strip MIME headers since it will be ASCII armoured.
 293       (forward-line 1)
 294       (delete-region (point-min) (point))
 295       (when cte
 296         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 297   (unless (let ((pgg-text-mode t))
 298             (pgg-encrypt-region
 299              (point-min) (point-max)
 300              (split-string
 301               (or
 302                (message-options-get 'message-recipients)
 303                (message-options-set 'message-recipients
 304                                     (read-string "Recipients: ")))
 305               "[ \f\t\n\r\v,]+")
 306              sign))
 307     (pop-to-buffer pgg-errors-buffer)
 308     (error "Encrypt error"))
 309   (delete-region (point-min) (point-max))
 310   (insert "\n")
 311   (insert-buffer-substring pgg-output-buffer)
 312   t)
 313
 314 ;; epg wrapper
 315
 316 (eval-and-compile
 317   (autoload 'epg-make-context "epg"))
 318
 319 (eval-when-compile
 320   (defvar epg-user-id-alist)
 321   (autoload 'epg-passphrase-callback-function "epg")
 322   (autoload 'epa-select-keys "epa")
 323   (autoload 'epg-list-keys "epg")
 324   (autoload 'epg-context-set-armor "epg")
 325   (autoload 'epg-context-set-textmode "epg")
 326   (autoload 'epg-context-set-signers "epg")
 327   (autoload 'epg-context-set-passphrase-callback "epg")
 328   (autoload 'epg-sign-string "epg")
 329   (autoload 'epg-encrypt-string "epg"))
 330
 331 (eval-when-compile
 332   (defvar password-cache-expiry)
 333   (autoload 'password-read "password")
 334   (autoload 'password-cache-add "password")
 335   (autoload 'password-cache-remove "password"))
 336
 337 (defvar mml1991-epg-secret-key-id-list nil)
 338
 339 (defun mml1991-epg-passphrase-callback (context key-id ignore)
 340   (if (eq key-id 'SYM)
 341       (epg-passphrase-callback-function context key-id nil)
 342     (let* ((entry (assoc key-id epg-user-id-alist))
 343            (passphrase
 344             (password-read
 345              (format "GnuPG passphrase for %s: "
 346                      (if entry
 347                          (cdr entry)
 348                        key-id))
 349              (if (eq key-id 'PIN)
 350                  "PIN"
 351                key-id))))
 352       (when passphrase
 353         (let ((password-cache-expiry mml1991-passphrase-cache-expiry))
 354           (password-cache-add key-id passphrase))
 355         (setq mml1991-epg-secret-key-id-list
 356               (cons key-id mml1991-epg-secret-key-id-list))
 357         (copy-sequence passphrase)))))
 358
 359 (defun mml1991-epg-sign (cont)
 360   (let ((context (epg-make-context))
 361         headers cte signers signature)
 362     (if mml1991-verbose
 363         (setq signers (epa-select-keys context "Select keys for signing.
 364 If no one is selected, default secret key is used.  "
 365                                        mml1991-signers t))
 366       (setq signers (mapcar (lambda (name)
 367                               (car (epg-list-keys context name t)))
 368                             (or mml1991-signers
 369                                 (list (message-options-get 'mml-sender))))))
 370     (epg-context-set-armor context t)
 371     (epg-context-set-textmode context t)
 372     (epg-context-set-signers context signers)
 373     (if mml1991-cache-passphrase
 374         (epg-context-set-passphrase-callback
 375          context
 376          #'mml1991-epg-passphrase-callback))
 377     ;; Don't sign headers.
 378     (goto-char (point-min))
 379     (when (re-search-forward "^$" nil t)
 380       (setq headers (buffer-substring (point-min) (point)))
 381       (save-restriction
 382         (narrow-to-region (point-min) (point))
 383         (setq cte (mail-fetch-field "content-transfer-encoding")))
 384       (forward-line 1)
 385       (delete-region (point-min) (point))
 386       (when cte
 387         (setq cte (intern (downcase cte)))
 388         (mm-decode-content-transfer-encoding cte)))
 389     (condition-case error
 390         (setq signature (epg-sign-string context (buffer-string) 'clear)
 391               mml1991-epg-secret-key-id-list nil)
 392       (error
 393        (while mml1991-epg-secret-key-id-list
 394          (password-cache-remove (car mml1991-epg-secret-key-id-list))
 395          (setq mml1991-epg-secret-key-id-list
 396                (cdr mml1991-epg-secret-key-id-list)))
 397        (signal (car error) (cdr error))))
 398     (delete-region (point-min) (point-max))
 399     (mm-with-unibyte-current-buffer
 400       (insert signature)
 401       (goto-char (point-min))
 402       (while (re-search-forward "\r+$" nil t)
 403         (replace-match "" t t))
 404       (when cte
 405         (mm-encode-content-transfer-encoding cte))
 406       (goto-char (point-min))
 407       (when headers
 408         (insert headers))
 409       (insert "\n"))
 410     t))
 411
 412 (defun mml1991-epg-encrypt (cont &optional sign)
 413   (goto-char (point-min))
 414   (when (re-search-forward "^$" nil t)
 415     (let ((cte (save-restriction
 416                  (narrow-to-region (point-min) (point))
 417                  (mail-fetch-field "content-transfer-encoding"))))
 418       ;; Strip MIME headers since it will be ASCII armoured.
 419       (forward-line 1)
 420       (delete-region (point-min) (point))
 421       (when cte
 422         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 423   (let ((context (epg-make-context))
 424         recipients cipher signers)
 425     (if (or mml1991-verbose
 426             (null (message-options-get 'message-recipients)))
 427         (setq recipients
 428               (epa-select-keys context "Select recipients for encryption.
 429 If no one is selected, symmetric encryption will be performed.  "
 430                                (if (message-options-get 'message-recipients)
 431                                    (split-string
 432                                     (message-options-get 'message-recipients)
 433                                     "[ \f\t\n\r\v,]+"))))
 434       (setq recipients
 435             (mapcar (lambda (name)
 436                       (car (epg-list-keys context name)))
 437                     (split-string
 438                      (message-options-get 'message-recipients)
 439                      "[ \f\t\n\r\v,]+"))))
 440     (if mml1991-encrypt-to-self
 441         (setq recipients
 442               (nconc recipients
 443                      (mapcar (lambda (name)
 444                                (car (epg-list-keys context name)))
 445                              mml1991-signers))))
 446     (when sign
 447       (if mml1991-verbose
 448           (setq signers (epa-select-keys context "Select keys for signing.
 449 If no one is selected, default secret key is used.  "
 450                                          mml1991-signers t))
 451         (setq signers (mapcar (lambda (name)
 452                                 (car (epg-list-keys context name t)))
 453                               (or mml1991-signers
 454                                   (list (message-options-get 'mml-sender))))))
 455       (epg-context-set-signers context signers))
 456     (epg-context-set-armor context t)
 457     (epg-context-set-textmode context t)
 458     (if mml1991-cache-passphrase
 459         (epg-context-set-passphrase-callback
 460          context
 461          #'mml1991-epg-passphrase-callback))
 462     (condition-case error
 463         (setq cipher
 464               (epg-encrypt-string context (buffer-string) recipients sign)
 465               mml1991-epg-secret-key-id-list nil)
 466       (error
 467        (while mml1991-epg-secret-key-id-list
 468          (password-cache-remove (car mml1991-epg-secret-key-id-list))
 469          (setq mml1991-epg-secret-key-id-list
 470                (cdr mml1991-epg-secret-key-id-list)))
 471        (signal (car error) (cdr error))))
 472     (delete-region (point-min) (point-max))
 473     (insert "\n" cipher))
 474   t)
 475
 476 ;;;###autoload
 477 (defun mml1991-encrypt (cont &optional sign)
 478   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
 479     (if func
 480         (funcall func cont sign)
 481       (error "Cannot find encrypt function"))))
 482
 483 ;;;###autoload
 484 (defun mml1991-sign (cont)
 485   (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
 486     (if func
 487         (funcall func cont)
 488       (error "Cannot find sign function"))))
 489
 490 (provide 'mml1991)
 491
 492 ;; Local Variables:
 493 ;; coding: iso-8859-1
 494 ;; End:
 495
 496 ;;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706
 497 ;;; mml1991.el ends here