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 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 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   (autoload 'epg-configuration "epg-config")
 331   (autoload 'epg-expand-group "epg-config"))
 332
 333 (eval-when-compile
 334   (defvar password-cache-expiry)
 335   (autoload 'password-read "password")
 336   (autoload 'password-cache-add "password")
 337   (autoload 'password-cache-remove "password"))
 338
 339 (defvar mml1991-epg-secret-key-id-list nil)
 340
 341 (defun mml1991-epg-passphrase-callback (context key-id ignore)
 342   (if (eq key-id 'SYM)
 343       (epg-passphrase-callback-function context key-id nil)
 344     (let* ((entry (assoc key-id epg-user-id-alist))
 345            (passphrase
 346             (password-read
 347              (format "GnuPG passphrase for %s: "
 348                      (if entry
 349                          (cdr entry)
 350                        key-id))
 351              (if (eq key-id 'PIN)
 352                  "PIN"
 353                key-id))))
 354       (when passphrase
 355         (let ((password-cache-expiry mml1991-passphrase-cache-expiry))
 356           (password-cache-add key-id passphrase))
 357         (setq mml1991-epg-secret-key-id-list
 358               (cons key-id mml1991-epg-secret-key-id-list))
 359         (copy-sequence passphrase)))))
 360
 361 (defun mml1991-epg-sign (cont)
 362   (let ((context (epg-make-context))
 363         headers cte signers signature)
 364     (if mml1991-verbose
 365         (setq signers (epa-select-keys context "Select keys for signing.
 366 If no one is selected, default secret key is used.  "
 367                                        mml1991-signers t))
 368       (if mml1991-signers
 369           (setq signers (mapcar (lambda (name)
 370                                   (car (epg-list-keys context name t)))
 371                                 mml1991-signers))
 372         (setq signers (list (car (epg-list-keys
 373                                   context
 374                                   (message-options-get 'mml-sender)
 375                                   t))))))
 376     (epg-context-set-armor context t)
 377     (epg-context-set-textmode context t)
 378     (epg-context-set-signers context signers)
 379     (if mml1991-cache-passphrase
 380         (epg-context-set-passphrase-callback
 381          context
 382          #'mml1991-epg-passphrase-callback))
 383     ;; Don't sign headers.
 384     (goto-char (point-min))
 385     (when (re-search-forward "^$" nil t)
 386       (setq headers (buffer-substring (point-min) (point)))
 387       (save-restriction
 388         (narrow-to-region (point-min) (point))
 389         (setq cte (mail-fetch-field "content-transfer-encoding")))
 390       (forward-line 1)
 391       (delete-region (point-min) (point))
 392       (when cte
 393         (setq cte (intern (downcase cte)))
 394         (mm-decode-content-transfer-encoding cte)))
 395     (condition-case error
 396         (setq signature (epg-sign-string context (buffer-string) 'clear)
 397               mml1991-epg-secret-key-id-list nil)
 398       (error
 399        (while mml1991-epg-secret-key-id-list
 400          (password-cache-remove (car mml1991-epg-secret-key-id-list))
 401          (setq mml1991-epg-secret-key-id-list
 402                (cdr mml1991-epg-secret-key-id-list)))
 403        (signal (car error) (cdr error))))
 404     (delete-region (point-min) (point-max))
 405     (mm-with-unibyte-current-buffer
 406       (insert signature)
 407       (goto-char (point-min))
 408       (while (re-search-forward "\r+$" nil t)
 409         (replace-match "" t t))
 410       (when cte
 411         (mm-encode-content-transfer-encoding cte))
 412       (goto-char (point-min))
 413       (when headers
 414         (insert headers))
 415       (insert "\n"))
 416     t))
 417
 418 (defun mml1991-epg-encrypt (cont &optional sign)
 419   (goto-char (point-min))
 420   (when (re-search-forward "^$" nil t)
 421     (let ((cte (save-restriction
 422                  (narrow-to-region (point-min) (point))
 423                  (mail-fetch-field "content-transfer-encoding"))))
 424       ;; Strip MIME headers since it will be ASCII armoured.
 425       (forward-line 1)
 426       (delete-region (point-min) (point))
 427       (when cte
 428         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 429   (let ((context (epg-make-context))
 430         (recipients
 431          (if (message-options-get 'message-recipients)
 432              (split-string
 433               (message-options-get 'message-recipients)
 434               "[ \f\t\n\r\v,]+")))
 435         cipher signers config)
 436     (if (and (condition-case nil
 437                  (require 'epg-config)
 438                (error))
 439              (functionp #'epg-expand-group))
 440         (setq config (epg-configuration)
 441               recipients
 442               (apply #'nconc
 443                      (mapcar (lambda (recipient)
 444                                (or (epg-expand-group config recipient)
 445                                    (list recipient)))
 446                              recipients))))
 447     (if mml1991-verbose
 448         (setq recipients
 449               (epa-select-keys context "Select recipients for encryption.
 450 If no one is selected, symmetric encryption will be performed.  "
 451                                recipients))
 452       (setq recipients
 453             (delq nil (mapcar (lambda (name)
 454                                 (car (epg-list-keys context name)))
 455                               recipients))))
 456     (if mml1991-encrypt-to-self
 457         (if mml1991-signers
 458             (setq recipients
 459                   (nconc recipients
 460                          (mapcar (lambda (name)
 461                                    (car (epg-list-keys context name)))
 462                                  mml1991-signers)))
 463           (setq recipients
 464                 (nconc recipients
 465                        (list (car (epg-list-keys context nil t)))))))
 466     (when sign
 467       (if mml1991-verbose
 468           (setq signers (epa-select-keys context "Select keys for signing.
 469 If no one is selected, default secret key is used.  "
 470                                          mml1991-signers t))
 471         (if mml1991-signers
 472             (setq signers (mapcar (lambda (name)
 473                                     (car (epg-list-keys context name t)))
 474                                   mml1991-signers))
 475           (setq signers (list (car (epg-list-keys
 476                                     context
 477                                     (message-options-get 'mml-sender)
 478                                     t))))))
 479       (epg-context-set-signers context signers))
 480     (epg-context-set-armor context t)
 481     (epg-context-set-textmode context t)
 482     (if mml1991-cache-passphrase
 483         (epg-context-set-passphrase-callback
 484          context
 485          #'mml1991-epg-passphrase-callback))
 486     (condition-case error
 487         (setq cipher
 488               (epg-encrypt-string context (buffer-string) recipients sign)
 489               mml1991-epg-secret-key-id-list nil)
 490       (error
 491        (while mml1991-epg-secret-key-id-list
 492          (password-cache-remove (car mml1991-epg-secret-key-id-list))
 493          (setq mml1991-epg-secret-key-id-list
 494                (cdr mml1991-epg-secret-key-id-list)))
 495        (signal (car error) (cdr error))))
 496     (delete-region (point-min) (point-max))
 497     (insert "\n" cipher))
 498   t)
 499
 500 ;;;###autoload
 501 (defun mml1991-encrypt (cont &optional sign)
 502   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
 503     (if func
 504         (funcall func cont sign)
 505       (error "Cannot find encrypt function"))))
 506
 507 ;;;###autoload
 508 (defun mml1991-sign (cont)
 509   (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
 510     (if func
 511         (funcall func cont)
 512       (error "Cannot find sign function"))))
 513
 514 (provide 'mml1991)
 515
 516 ;; Local Variables:
 517 ;; coding: iso-8859-1
 518 ;; End:
 519
 520 ;;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706
 521 ;;; mml1991.el ends here