code.delx.au - gnu-emacs/blob - lisp/gnus/mml1991.el

   1 ;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
   2
   3 ;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Sascha Lüdecke <sascha@meta-x.de>,
   6 ;;      Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
   7 ;; Keywords: PGP
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-and-compile
  29   (if (locate-library "password-cache")
  30       (require 'password-cache)
  31     (require 'password)))
  32
  33 (eval-when-compile
  34   (require 'cl)
  35   (require 'mm-util))
  36
  37 (require 'mm-encode)
  38 (require 'mml-sec)
  39
  40 (defvar mc-pgp-always-sign)
  41
  42 (autoload 'quoted-printable-decode-region "qp")
  43 (autoload 'quoted-printable-encode-region "qp")
  44
  45 (autoload 'mm-decode-content-transfer-encoding "mm-bodies")
  46 (autoload 'mm-encode-content-transfer-encoding "mm-bodies")
  47 (autoload 'message-options-get "message")
  48 (autoload 'message-options-set "message")
  49
  50 (require 'mml2015)
  51
  52 (defvar mml1991-use mml2015-use
  53   "The package used for PGP.")
  54
  55 (defvar mml1991-function-alist
  56   '((mailcrypt mml1991-mailcrypt-sign
  57                mml1991-mailcrypt-encrypt)
  58     (pgg mml1991-pgg-sign
  59          mml1991-pgg-encrypt)
  60     (epg mml1991-epg-sign
  61          mml1991-epg-encrypt))
  62   "Alist of PGP functions.")
  63
  64 (defvar mml1991-cache-passphrase mml-secure-cache-passphrase
  65   "If t, cache passphrase.")
  66 (make-obsolete-variable 'mml1991-cache-passphrase
  67                         'mml-secure-cache-passphrase
  68                         "25.1")
  69
  70 (defvar mml1991-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
  71   "How many seconds the passphrase is cached.
  72 Whether the passphrase is cached at all is controlled by
  73 `mml1991-cache-passphrase'.")
  74 (make-obsolete-variable 'mml1991-passphrase-cache-expiry
  75                         'mml-secure-passphrase-cache-expiry
  76                         "25.1")
  77
  78 (defvar mml1991-signers nil
  79   "A list of your own key ID which will be used to sign a message.")
  80
  81 (defvar mml1991-encrypt-to-self nil
  82   "If t, add your own key ID to recipient list when encryption.")
  83
  84
  85 ;;; mailcrypt wrapper
  86
  87 (autoload 'mc-sign-generic "mc-toplev")
  88
  89 (defvar mml1991-decrypt-function 'mailcrypt-decrypt)
  90 (defvar mml1991-verify-function 'mailcrypt-verify)
  91
  92 (defun mml1991-mailcrypt-sign (cont)
  93   (let ((text (current-buffer))
  94         headers signature
  95         (result-buffer (get-buffer-create "*GPG Result*")))
  96     ;; Save MIME Content[^ ]+: headers from signing
  97     (goto-char (point-min))
  98     (while (looking-at "^Content[^ ]+:") (forward-line))
  99     (unless (bobp)
 100       (setq headers (buffer-string))
 101       (delete-region (point-min) (point)))
 102     (goto-char (point-max))
 103     (unless (bolp)
 104       (insert "\n"))
 105     (quoted-printable-decode-region (point-min) (point-max))
 106     (with-temp-buffer
 107       (setq signature (current-buffer))
 108       (insert-buffer-substring text)
 109       (unless (mc-sign-generic (message-options-get 'message-sender)
 110                                nil nil nil nil)
 111         (unless (> (point-max) (point-min))
 112           (pop-to-buffer result-buffer)
 113           (error "Sign error")))
 114       (goto-char (point-min))
 115       (while (re-search-forward "\r+$" nil t)
 116         (replace-match "" t t))
 117       (quoted-printable-encode-region (point-min) (point-max))
 118       (set-buffer text)
 119       (delete-region (point-min) (point-max))
 120       (if headers (insert headers))
 121       (insert "\n")
 122       (insert-buffer-substring signature)
 123       (goto-char (point-max)))))
 124
 125 (declare-function mc-encrypt-generic "ext:mc-toplev"
 126                   (&optional recipients scheme start end from sign))
 127
 128 (defun mml1991-mailcrypt-encrypt (cont &optional sign)
 129   (let ((text (current-buffer))
 130         (mc-pgp-always-sign
 131          (or mc-pgp-always-sign
 132              sign
 133              (eq t (or (message-options-get 'message-sign-encrypt)
 134                        (message-options-set
 135                         'message-sign-encrypt
 136                         (or (y-or-n-p "Sign the message? ")
 137                             'not))))
 138              'never))
 139         cipher
 140         (result-buffer (get-buffer-create "*GPG Result*")))
 141     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED
 142     (goto-char (point-min))
 143     (while (looking-at "^Content[^ ]+:") (forward-line))
 144     (unless (bobp)
 145       (delete-region (point-min) (point)))
 146     (with-temp-buffer
 147       (inline (mm-disable-multibyte))
 148       (setq cipher (current-buffer))
 149       (insert-buffer-substring text)
 150       (unless (mc-encrypt-generic
 151                (or
 152                 (message-options-get 'message-recipients)
 153                 (message-options-set 'message-recipients
 154                                      (read-string "Recipients: ")))
 155                nil
 156                (point-min) (point-max)
 157                (message-options-get 'message-sender)
 158                'sign)
 159         (unless (> (point-max) (point-min))
 160           (pop-to-buffer result-buffer)
 161           (error "Encrypt error")))
 162       (goto-char (point-min))
 163       (while (re-search-forward "\r+$" nil t)
 164         (replace-match "" t t))
 165       (set-buffer text)
 166       (delete-region (point-min) (point-max))
 167       ;;(insert "Content-Type: application/pgp-encrypted\n\n")
 168       ;;(insert "Version: 1\n\n")
 169       (insert "\n")
 170       (insert-buffer-substring cipher)
 171       (goto-char (point-max)))))
 172
 173 ;; pgg wrapper
 174
 175 (autoload 'pgg-sign-region "pgg")
 176 (autoload 'pgg-encrypt-region "pgg")
 177
 178 (defvar pgg-default-user-id)
 179 (defvar pgg-errors-buffer)
 180 (defvar pgg-output-buffer)
 181
 182 (defun mml1991-pgg-sign (cont)
 183   (let ((pgg-text-mode t)
 184         (pgg-default-user-id (or (message-options-get 'mml-sender)
 185                                  pgg-default-user-id))
 186         headers cte)
 187     ;; Don't sign headers.
 188     (goto-char (point-min))
 189     (when (re-search-forward "^$" nil t)
 190       (setq headers (buffer-substring (point-min) (point)))
 191       (save-restriction
 192         (narrow-to-region (point-min) (point))
 193         (setq cte (mail-fetch-field "content-transfer-encoding")))
 194       (forward-line 1)
 195       (delete-region (point-min) (point))
 196       (when cte
 197         (setq cte (intern (downcase cte)))
 198         (mm-decode-content-transfer-encoding cte)))
 199     (unless (pgg-sign-region (point-min) (point-max) t)
 200       (pop-to-buffer pgg-errors-buffer)
 201       (error "Encrypt error"))
 202     (delete-region (point-min) (point-max))
 203     (insert
 204      (with-temp-buffer
 205        (set-buffer-multibyte nil)
 206        (insert-buffer-substring pgg-output-buffer)
 207        (goto-char (point-min))
 208        (while (re-search-forward "\r+$" nil t)
 209          (replace-match "" t t))
 210        (when cte
 211          (mm-encode-content-transfer-encoding cte))
 212        (goto-char (point-min))
 213        (when headers
 214          (insert headers))
 215        (insert "\n")
 216        (buffer-string)))
 217     t))
 218
 219 (defun mml1991-pgg-encrypt (cont &optional sign)
 220   (goto-char (point-min))
 221   (when (re-search-forward "^$" nil t)
 222     (let ((cte (save-restriction
 223                  (narrow-to-region (point-min) (point))
 224                  (mail-fetch-field "content-transfer-encoding"))))
 225       ;; Strip MIME headers since it will be ASCII armored.
 226       (forward-line 1)
 227       (delete-region (point-min) (point))
 228       (when cte
 229         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 230   (unless (let ((pgg-text-mode t))
 231             (pgg-encrypt-region
 232              (point-min) (point-max)
 233              (split-string
 234               (or
 235                (message-options-get 'message-recipients)
 236                (message-options-set 'message-recipients
 237                                     (read-string "Recipients: ")))
 238               "[ \f\t\n\r\v,]+")
 239              sign))
 240     (pop-to-buffer pgg-errors-buffer)
 241     (error "Encrypt error"))
 242   (delete-region (point-min) (point-max))
 243   (insert "\n")
 244   (insert-buffer-substring pgg-output-buffer)
 245   t)
 246
 247 ;; epg wrapper
 248
 249 (defvar epg-user-id-alist)
 250
 251 (autoload 'epg-make-context "epg")
 252 (autoload 'epg-passphrase-callback-function "epg")
 253 (autoload 'epa-select-keys "epa")
 254 (autoload 'epg-list-keys "epg")
 255 (autoload 'epg-context-set-armor "epg")
 256 (autoload 'epg-context-set-textmode "epg")
 257 (autoload 'epg-context-set-signers "epg")
 258 (autoload 'epg-context-set-passphrase-callback "epg")
 259 (autoload 'epg-key-sub-key-list "epg")
 260 (autoload 'epg-sub-key-capability "epg")
 261 (autoload 'epg-sub-key-validity "epg")
 262 (autoload 'epg-sub-key-fingerprint "epg")
 263 (autoload 'epg-sign-string "epg")
 264 (autoload 'epg-encrypt-string "epg")
 265 (autoload 'epg-configuration "epg-config")
 266 (autoload 'epg-expand-group "epg-config")
 267
 268 (defun mml1991-epg-sign (cont)
 269   (let ((inhibit-redisplay t)
 270         headers cte)
 271     ;; Don't sign headers.
 272     (goto-char (point-min))
 273     (when (re-search-forward "^$" nil t)
 274       (setq headers (buffer-substring (point-min) (point)))
 275       (save-restriction
 276         (narrow-to-region (point-min) (point))
 277         (setq cte (mail-fetch-field "content-transfer-encoding")))
 278       (forward-line 1)
 279       (delete-region (point-min) (point))
 280       (when cte
 281         (setq cte (intern (downcase cte)))
 282         (mm-decode-content-transfer-encoding cte)))
 283     (let* ((pair (mml-secure-epg-sign 'OpenPGP 'clear))
 284            (signature (car pair)))
 285       (delete-region (point-min) (point-max))
 286       (insert
 287        (with-temp-buffer
 288          (set-buffer-multibyte nil)
 289          (insert signature)
 290          (goto-char (point-min))
 291          (while (re-search-forward "\r+$" nil t)
 292            (replace-match "" t t))
 293          (when cte
 294            (mm-encode-content-transfer-encoding cte))
 295          (goto-char (point-min))
 296          (when headers
 297            (insert headers))
 298          (insert "\n")
 299          (buffer-string)))
 300       t)))
 301
 302 (defun mml1991-epg-encrypt (cont &optional sign)
 303   (goto-char (point-min))
 304   (when (re-search-forward "^$" nil t)
 305     (let ((cte (save-restriction
 306                  (narrow-to-region (point-min) (point))
 307                  (mail-fetch-field "content-transfer-encoding"))))
 308       ;; Strip MIME headers since it will be ASCII armored.
 309       (forward-line 1)
 310       (delete-region (point-min) (point))
 311       (when cte
 312         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 313   (let ((cipher (mml-secure-epg-encrypt 'OpenPGP cont sign)))
 314     (delete-region (point-min) (point-max))
 315     (insert "\n" cipher))
 316   t)
 317
 318 ;;;###autoload
 319 (defun mml1991-encrypt (cont &optional sign)
 320   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
 321     (if func
 322         (funcall func cont sign)
 323       (error "Cannot find encrypt function"))))
 324
 325 ;;;###autoload
 326 (defun mml1991-sign (cont)
 327   (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
 328     (if func
 329         (funcall func cont)
 330       (error "Cannot find sign function"))))
 331
 332 (provide 'mml1991)
 333
 334 ;; Local Variables:
 335 ;; coding: utf-8
 336 ;; End:
 337
 338 ;;; mml1991.el ends here