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 (defvar mc-pgp-always-sign)
  36
  37 (autoload 'quoted-printable-decode-region "qp")
  38 (autoload 'quoted-printable-encode-region "qp")
  39
  40 (defvar mml1991-use mml2015-use
  41   "The package used for PGP.")
  42
  43 (defvar mml1991-function-alist
  44   '((mailcrypt mml1991-mailcrypt-sign
  45                mml1991-mailcrypt-encrypt)
  46     (gpg mml1991-gpg-sign
  47          mml1991-gpg-encrypt)
  48     (pgg mml1991-pgg-sign
  49          mml1991-pgg-encrypt)
  50     (epg mml1991-epg-sign
  51          mml1991-epg-encrypt))
  52   "Alist of PGP functions.")
  53
  54 (defvar mml1991-verbose nil
  55   "If non-nil, ask the user about the current operation more verbosely.")
  56
  57 (defvar mml1991-cache-passphrase t
  58   "If t, cache passphrase.")
  59
  60 (defvar mml1991-passphrase-cache-expiry 16
  61   "How many seconds the passphrase is cached.
  62 Whether the passphrase is cached at all is controlled by
  63 `mml1991-cache-passphrase'.")
  64
  65 ;;; mailcrypt wrapper
  66
  67 (eval-and-compile
  68   (autoload 'mc-sign-generic "mc-toplev"))
  69
  70 (defvar mml1991-decrypt-function 'mailcrypt-decrypt)
  71 (defvar mml1991-verify-function 'mailcrypt-verify)
  72
  73 (defun mml1991-mailcrypt-sign (cont)
  74   (let ((text (current-buffer))
  75         headers signature
  76         (result-buffer (get-buffer-create "*GPG Result*")))
  77     ;; Save MIME Content[^ ]+: headers from signing
  78     (goto-char (point-min))
  79     (while (looking-at "^Content[^ ]+:") (forward-line))
  80     (unless (bobp)
  81       (setq headers (buffer-string))
  82       (delete-region (point-min) (point)))
  83     (goto-char (point-max))
  84     (unless (bolp)
  85       (insert "\n"))
  86     (quoted-printable-decode-region (point-min) (point-max))
  87     (with-temp-buffer
  88       (setq signature (current-buffer))
  89       (insert-buffer-substring text)
  90       (unless (mc-sign-generic (message-options-get 'message-sender)
  91                                nil nil nil nil)
  92         (unless (> (point-max) (point-min))
  93           (pop-to-buffer result-buffer)
  94           (error "Sign error")))
  95       (goto-char (point-min))
  96       (while (re-search-forward "\r+$" nil t)
  97         (replace-match "" t t))
  98       (quoted-printable-encode-region (point-min) (point-max))
  99       (set-buffer text)
 100       (delete-region (point-min) (point-max))
 101       (if headers (insert headers))
 102       (insert "\n")
 103       (insert-buffer-substring signature)
 104       (goto-char (point-max)))))
 105
 106 (defun mml1991-mailcrypt-encrypt (cont &optional sign)
 107   (let ((text (current-buffer))
 108         (mc-pgp-always-sign
 109          (or mc-pgp-always-sign
 110              sign
 111              (eq t (or (message-options-get 'message-sign-encrypt)
 112                        (message-options-set
 113                         'message-sign-encrypt
 114                         (or (y-or-n-p "Sign the message? ")
 115                             'not))))
 116              'never))
 117         cipher
 118         (result-buffer (get-buffer-create "*GPG Result*")))
 119     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
 120     (goto-char (point-min))
 121     (while (looking-at "^Content[^ ]+:") (forward-line))
 122     (unless (bobp)
 123       (delete-region (point-min) (point)))
 124     (mm-with-unibyte-current-buffer
 125       (with-temp-buffer
 126         (setq cipher (current-buffer))
 127         (insert-buffer-substring text)
 128         (unless (mc-encrypt-generic
 129                  (or
 130                   (message-options-get 'message-recipients)
 131                   (message-options-set 'message-recipients
 132                                        (read-string "Recipients: ")))
 133                  nil
 134                  (point-min) (point-max)
 135                  (message-options-get 'message-sender)
 136                  'sign)
 137           (unless (> (point-max) (point-min))
 138             (pop-to-buffer result-buffer)
 139             (error "Encrypt error")))
 140         (goto-char (point-min))
 141         (while (re-search-forward "\r+$" nil t)
 142           (replace-match "" t t))
 143         (set-buffer text)
 144         (delete-region (point-min) (point-max))
 145         ;;(insert "Content-Type: application/pgp-encrypted\n\n")
 146         ;;(insert "Version: 1\n\n")
 147         (insert "\n")
 148         (insert-buffer-substring cipher)
 149         (goto-char (point-max))))))
 150
 151 ;;; gpg wrapper
 152
 153 (eval-and-compile
 154   (autoload 'gpg-sign-cleartext "gpg"))
 155
 156 (defun mml1991-gpg-sign (cont)
 157   (let ((text (current-buffer))
 158         headers signature
 159         (result-buffer (get-buffer-create "*GPG Result*")))
 160     ;; Save MIME Content[^ ]+: headers from signing
 161     (goto-char (point-min))
 162     (while (looking-at "^Content[^ ]+:") (forward-line))
 163     (unless (bobp)
 164       (setq headers (buffer-string))
 165       (delete-region (point-min) (point)))
 166     (goto-char (point-max))
 167     (unless (bolp)
 168       (insert "\n"))
 169     (quoted-printable-decode-region (point-min) (point-max))
 170     (with-temp-buffer
 171       (unless (gpg-sign-cleartext text (setq signature (current-buffer))
 172                                   result-buffer
 173                                   nil
 174                                   (message-options-get 'message-sender))
 175         (unless (> (point-max) (point-min))
 176           (pop-to-buffer result-buffer)
 177           (error "Sign error")))
 178       (goto-char (point-min))
 179       (while (re-search-forward "\r+$" nil t)
 180         (replace-match "" t t))
 181       (quoted-printable-encode-region (point-min) (point-max))
 182       (set-buffer text)
 183       (delete-region (point-min) (point-max))
 184       (if headers (insert headers))
 185       (insert "\n")
 186       (insert-buffer-substring signature)
 187       (goto-char (point-max)))))
 188
 189 (defun mml1991-gpg-encrypt (cont &optional sign)
 190   (let ((text (current-buffer))
 191         cipher
 192         (result-buffer (get-buffer-create "*GPG Result*")))
 193     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
 194     (goto-char (point-min))
 195     (while (looking-at "^Content[^ ]+:") (forward-line))
 196     (unless (bobp)
 197       (delete-region (point-min) (point)))
 198     (mm-with-unibyte-current-buffer
 199       (with-temp-buffer
 200         (flet ((gpg-encrypt-func
 201                 (sign plaintext ciphertext result recipients &optional
 202                       passphrase sign-with-key armor textmode)
 203                 (if sign
 204                     (gpg-sign-encrypt
 205                      plaintext ciphertext result recipients passphrase
 206                      sign-with-key armor textmode)
 207                   (gpg-encrypt
 208                    plaintext ciphertext result recipients passphrase
 209                    armor textmode))))
 210           (unless (gpg-encrypt-func
 211                    sign
 212                    text (setq cipher (current-buffer))
 213                    result-buffer
 214                    (split-string
 215                     (or
 216                      (message-options-get 'message-recipients)
 217                      (message-options-set 'message-recipients
 218                                           (read-string "Recipients: ")))
 219                     "[ \f\t\n\r\v,]+")
 220                    nil
 221                    (message-options-get 'message-sender)
 222                    t t) ; armor & textmode
 223             (unless (> (point-max) (point-min))
 224               (pop-to-buffer result-buffer)
 225               (error "Encrypt error"))))
 226         (goto-char (point-min))
 227         (while (re-search-forward "\r+$" nil t)
 228           (replace-match "" t t))
 229         (set-buffer text)
 230         (delete-region (point-min) (point-max))
 231         ;;(insert "Content-Type: application/pgp-encrypted\n\n")
 232         ;;(insert "Version: 1\n\n")
 233         (insert "\n")
 234         (insert-buffer-substring cipher)
 235         (goto-char (point-max))))))
 236
 237 ;; pgg wrapper
 238
 239 (eval-when-compile
 240   (defvar pgg-default-user-id)
 241   (defvar pgg-errors-buffer)
 242   (defvar pgg-output-buffer))
 243
 244 (defun mml1991-pgg-sign (cont)
 245   (let ((pgg-text-mode t)
 246         (pgg-default-user-id (or (message-options-get 'mml-sender)
 247                                  pgg-default-user-id))
 248         headers cte)
 249     ;; Don't sign headers.
 250     (goto-char (point-min))
 251     (when (re-search-forward "^$" nil t)
 252       (setq headers (buffer-substring (point-min) (point)))
 253       (save-restriction
 254         (narrow-to-region (point-min) (point))
 255         (setq cte (mail-fetch-field "content-transfer-encoding")))
 256       (forward-line 1)
 257       (delete-region (point-min) (point))
 258       (when cte
 259         (setq cte (intern (downcase cte)))
 260         (mm-decode-content-transfer-encoding cte)))
 261     (unless (pgg-sign-region (point-min) (point-max) t)
 262       (pop-to-buffer pgg-errors-buffer)
 263       (error "Encrypt error"))
 264     (delete-region (point-min) (point-max))
 265     (mm-with-unibyte-current-buffer
 266       (insert-buffer-substring pgg-output-buffer)
 267       (goto-char (point-min))
 268       (while (re-search-forward "\r+$" nil t)
 269         (replace-match "" t t))
 270       (when cte
 271         (mm-encode-content-transfer-encoding cte))
 272       (goto-char (point-min))
 273       (when headers
 274         (insert headers))
 275       (insert "\n"))
 276     t))
 277
 278 (defun mml1991-pgg-encrypt (cont &optional sign)
 279   (goto-char (point-min))
 280   (when (re-search-forward "^$" nil t)
 281     (let ((cte (save-restriction
 282                  (narrow-to-region (point-min) (point))
 283                  (mail-fetch-field "content-transfer-encoding"))))
 284       ;; Strip MIME headers since it will be ASCII armoured.
 285       (forward-line 1)
 286       (delete-region (point-min) (point))
 287       (when cte
 288         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 289   (unless (let ((pgg-text-mode t))
 290             (pgg-encrypt-region
 291              (point-min) (point-max)
 292              (split-string
 293               (or
 294                (message-options-get 'message-recipients)
 295                (message-options-set 'message-recipients
 296                                     (read-string "Recipients: ")))
 297               "[ \f\t\n\r\v,]+")
 298              sign))
 299     (pop-to-buffer pgg-errors-buffer)
 300     (error "Encrypt error"))
 301   (delete-region (point-min) (point-max))
 302   (insert "\n")
 303   (insert-buffer-substring pgg-output-buffer)
 304   t)
 305
 306 ;; epg wrapper
 307
 308 (eval-and-compile
 309   (autoload 'epg-make-context "epg"))
 310
 311 (eval-when-compile
 312   (defvar epg-user-id-alist)
 313   (autoload 'epg-passphrase-callback-function "epg")
 314   (autoload 'epa-select-keys "epa")
 315   (autoload 'epg-list-keys "epg")
 316
 317   (autoload 'epg-context-set-armor "epg")
 318   (autoload 'epg-context-set-textmode "epg")
 319
 320   (autoload 'epg-context-set-signers "epg")
 321   (autoload 'epg-context-set-passphrase-callback "epg")
 322
 323   (autoload 'epg-sign-string "epg")
 324   (autoload 'epg-encrypt-string "epg"))
 325
 326 (defvar mml1991-epg-secret-key-id-list nil)
 327
 328 (defun mml1991-epg-passphrase-callback (context key-id ignore)
 329   (if (eq key-id 'SYM)
 330       (epg-passphrase-callback-function context key-id nil)
 331     (let* ((entry (assoc key-id epg-user-id-alist))
 332            (passphrase
 333             (password-read
 334              (format "GnuPG passphrase for %s: "
 335                      (if entry
 336                          (cdr entry)
 337                        key-id))
 338              (if (eq key-id 'PIN)
 339                  "PIN"
 340                key-id))))
 341       (when passphrase
 342         (let ((password-cache-expiry mml1991-passphrase-cache-expiry))
 343           (password-cache-add key-id passphrase))
 344         (setq mml1991-epg-secret-key-id-list
 345               (cons key-id mml1991-epg-secret-key-id-list))
 346         (copy-sequence passphrase)))))
 347
 348 (defun mml1991-epg-sign (cont)
 349   (let ((context (epg-make-context))
 350         headers cte signers signature)
 351     (if mml1991-verbose
 352         (setq signers (epa-select-keys context "Select keys for signing.
 353 If no one is selected, default secret key is used.  "
 354                                        nil t))
 355       (setq signers (list (car (epg-list-keys
 356                                 context
 357                                 (message-options-get 'mml-sender) t)))))
 358     (epg-context-set-armor context t)
 359     (epg-context-set-textmode context t)
 360     (epg-context-set-signers context signers)
 361     (epg-context-set-passphrase-callback
 362      context
 363      #'mml1991-epg-passphrase-callback)
 364     ;; Don't sign headers.
 365     (goto-char (point-min))
 366     (when (re-search-forward "^$" nil t)
 367       (setq headers (buffer-substring (point-min) (point)))
 368       (save-restriction
 369         (narrow-to-region (point-min) (point))
 370         (setq cte (mail-fetch-field "content-transfer-encoding")))
 371       (forward-line 1)
 372       (delete-region (point-min) (point))
 373       (when cte
 374         (setq cte (intern (downcase cte)))
 375         (mm-decode-content-transfer-encoding cte)))
 376     (condition-case error
 377         (setq signature (epg-sign-string context (buffer-string) 'clear)
 378               mml1991-epg-secret-key-id-list nil)
 379       (error
 380        (while mml1991-epg-secret-key-id-list
 381          (password-cache-remove (car mml1991-epg-secret-key-id-list))
 382          (setq mml1991-epg-secret-key-id-list
 383                (cdr mml1991-epg-secret-key-id-list)))
 384        (signal (car error) (cdr error))))
 385     (delete-region (point-min) (point-max))
 386     (mm-with-unibyte-current-buffer
 387       (insert signature)
 388       (goto-char (point-min))
 389       (while (re-search-forward "\r+$" nil t)
 390         (replace-match "" t t))
 391       (when cte
 392         (mm-encode-content-transfer-encoding cte))
 393       (goto-char (point-min))
 394       (when headers
 395         (insert headers))
 396       (insert "\n"))
 397     t))
 398
 399 (defun mml1991-epg-encrypt (cont &optional sign)
 400   (goto-char (point-min))
 401   (when (re-search-forward "^$" nil t)
 402     (let ((cte (save-restriction
 403                  (narrow-to-region (point-min) (point))
 404                  (mail-fetch-field "content-transfer-encoding"))))
 405       ;; Strip MIME headers since it will be ASCII armoured.
 406       (forward-line 1)
 407       (delete-region (point-min) (point))
 408       (when cte
 409         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 410   (let ((context (epg-make-context))
 411         recipients cipher)
 412     (if (or mml1991-verbose
 413             (null (message-options-get 'message-recipients)))
 414         (setq recipients
 415               (epa-select-keys context "Select recipients for encryption.
 416 If no one is selected, symmetric encryption will be performed.  "
 417                                (if (message-options-get 'message-recipients)
 418                                    (split-string
 419                                     (message-options-get 'message-recipients)
 420                                     "[ \f\t\n\r\v,]+"))))
 421       (setq recipients
 422             (mapcar (lambda (name)
 423                       (car (epg-list-keys context name)))
 424                     (split-string
 425                      (message-options-get 'message-recipients)
 426                      "[ \f\t\n\r\v,]+"))))
 427     (epg-context-set-armor context t)
 428     (epg-context-set-textmode context t)
 429     (epg-context-set-passphrase-callback
 430      context
 431      #'mml1991-epg-passphrase-callback)
 432     (condition-case error
 433         (setq cipher
 434               (epg-encrypt-string context (buffer-string) recipients sign)
 435               mml1991-epg-secret-key-id-list nil)
 436       (error
 437        (while mml1991-epg-secret-key-id-list
 438          (password-cache-remove (car mml1991-epg-secret-key-id-list))
 439          (setq mml1991-epg-secret-key-id-list
 440                (cdr mml1991-epg-secret-key-id-list)))
 441        (signal (car error) (cdr error))))
 442     (delete-region (point-min) (point-max))
 443     (insert "\n" cipher))
 444   t)
 445
 446 ;;;###autoload
 447 (defun mml1991-encrypt (cont &optional sign)
 448   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
 449     (if func
 450         (funcall func cont sign)
 451       (error "Cannot find encrypt function"))))
 452
 453 ;;;###autoload
 454 (defun mml1991-sign (cont)
 455   (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
 456     (if func
 457         (funcall func cont)
 458       (error "Cannot find sign function"))))
 459
 460 (provide 'mml1991)
 461
 462 ;; Local Variables:
 463 ;; coding: iso-8859-1
 464 ;; End:
 465
 466 ;;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706
 467 ;;; mml1991.el ends here