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